home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue32 / kronos / KRONOS.ZIP / Kronos.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-02-25  |  134.3 KB  |  5,154 lines
  1. unit Kronos;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  7.  
  8. const
  9.  
  10.      ChurchDayCount = 21;
  11.      CommonDayCount = 4;
  12.  
  13.      {Daytype constants}
  14.      chAdvent1 = 1;
  15.      chAdvent2 = 2;
  16.      chAdvent3 = 3;
  17.      chAdvent4 = 4;
  18.      chChristmasEve = 5;
  19.      chChristmasDay = 6;
  20.      chBoxingDay = 7;
  21.  
  22.      chNewYearEve = 8;
  23.      chNewYearDay = 9;
  24.  
  25.      chAshWednesday = 10;
  26.      chShroveTuesday = 11;
  27.  
  28.      chPalmSunday = 12;
  29.      chMaundyThursday = 13;
  30.      chGoodFriday = 14;
  31.      chEasterEve = 15;
  32.      chEasterSunday = 16;
  33.      chEasterMonday = 17;
  34.  
  35.      chWhitEve = 18;
  36.      chWhitSunday = 19;
  37.      chWhitMonday = 20;
  38.      chAscensionDay = 21;
  39.  
  40.      coUNDay = 22;
  41.      coWomensDay = 23;
  42.      coMayDay = 24;
  43.      coLiteracyDay = 25;
  44.  
  45.      UserDayType = ChurchDayCount + CommonDayCount + 1;
  46.  
  47. type
  48.     TNameStr = string[50];
  49. {Internal types}
  50.     TCal = array[1..366] of Integer;
  51.     {Internal calendar with dates. Dates are formattted as
  52.     month * 100 + monthdays number}
  53.     TDaycodes = array[1..366,1..2] of word;
  54.     {Daycodes for churchdays (2) and internal dow-numbers (1)
  55.     dow-numbers are 1 for monday, 2 for sunday, etc. The churchdays codes
  56.     corresponds to the churchday constants}
  57.  
  58.     TFirstLastNumber = array[1..2] of Word;
  59.     {General type used to keep track of firt and last daynumbers for
  60.     months and weeks}
  61.     TChurchdayIndex = array[1..ChurchdayCount] of word;
  62.     {Keeps the indexes of the churchdays in the daycodes array}
  63.  
  64. {The following structures ares used to hold extracts form the internal
  65. calendar and code table}
  66.     TDay = record
  67.     {Day information}
  68.       Daynum : Word;
  69.       MonthDate : word;
  70.       DOWNum : word;
  71.       Month : word;
  72.       Week : word;
  73.       DayCode : Word;
  74.     end;
  75.  
  76.     TWeek = record
  77.     // Week information
  78.       WeekNum : word;
  79.       WhichDays : TFirstLastNumber;
  80.     end;
  81.  
  82.     TMonth = record
  83.     // Month information
  84.       Month : word;
  85.       Daycount : Word;
  86.       WeekCount : Word; {Antall uker ber°rte av mσneden}
  87.       WhichWeeks : TFirstLastNumber;
  88.       WhichDays : TFirstLastNumber;
  89.     end;
  90.  
  91.     TYear = record
  92.     // Year information
  93.       WeekCount : word;
  94.       DayCount : Word;
  95.     end;
  96.  
  97.     TKron = record
  98.     // Tracks which year that is loaded into the internal calendar
  99.       ActiveYear : Word;
  100.       IsInitialized : boolean;
  101.     end;
  102.  
  103.   {TKronos types:}
  104.   TDaytypeID = array[1..255] of word;
  105.  
  106.   TYearExt = record
  107.      Year : word;
  108.      NumDays : word;
  109.      NumWeeks : word;
  110.      LeapYear : boolean;
  111.      YeartypeCount : word;
  112.   end;
  113.  
  114.   TDateExt = record
  115.      Year : word;
  116.      DayOfWeekNumber : word;
  117.      DayName : string;
  118.      MonthDay : Word;
  119.      DayNumber : word;
  120.      DaytypeCount : word;
  121.      DaytypeID : TDaytypeID;
  122.      MonthNumber : word;
  123.      WeekNumber : word;
  124.      Holiday : boolean;
  125.      ChurchDay : Boolean;
  126.      Flagday : Boolean;
  127.   end;
  128.  
  129.   TMonthImage = array[1..6, 0..7] of smallint;
  130.   {Index 0 in second dimention contains weeknumbers, else daynumbers}
  131.  
  132.   TMonthExt = record
  133.      Year : word;
  134.      MonthNumber : word;
  135.      MonthName : string;
  136.      FirstDay, LastDay : word;
  137.      NumDays : word;
  138.      NumWeeks : word;
  139.      FirstWeek, LastWeek : word;
  140.      MonthImage : TMonthImage;
  141.   end;
  142.  
  143.   TWeekExt = record
  144.      Year : word;
  145.      WeekNumber : word;
  146.      FirstDay, LastDay : word;
  147.   end;
  148.  
  149.   TDaytypeDef = record // The record representation of TDaytype
  150.      AName : TNameStr;
  151.      ADate : word;
  152.      ARelDayType : word;
  153.      AnOffset : integer;
  154.      AFirstShowUp : word;
  155.      ALastShowUp : word;
  156.      AShowUpFrequency : word;
  157.      AChurchDay : boolean;
  158.      AHoliday : boolean;
  159.      AFlagday : boolean;
  160.      AUserCalc : boolean;
  161.      ATag : integer;
  162.   end;
  163.  
  164.   TDaytype = class(TPersistent)
  165.   //Class to hold the daytypes
  166.   private
  167.      FId : word;
  168.   protected
  169.      FName : TNameStr;
  170.      FDate : word;
  171.      FRelDayType : word;
  172.      FOffset : integer;
  173.      FFirstShowUp : word;
  174.      FLastShowUp : word;
  175.      FShowUpFrequency : word;
  176.      FChurchDay : boolean;
  177.      FHoliday : boolean;
  178.      FFlagday : boolean;
  179.      FUserCalc : boolean;
  180.      FTag : integer;
  181.  
  182.   published
  183.      property TheDate : word read FDate;
  184.      property TheName : TNameStr read FName;
  185.      property Id : word read FId;
  186.      property FirstShowUp : word read FFirstShowUp;
  187.      property LastShowUp : word read FLastShowUp;
  188.      property ShowUpFrequency : word read FShowupFrequency;
  189.      property RelDaytype : word read FRelDayType;
  190.      property Offset : integer read FOffset;
  191.      property ChurchDay : boolean read FChurchday;
  192.      property Holiday : boolean read FHoliday;
  193.      property Flagday : boolean read FFlagday;
  194.      property UserCalc : boolean read FUserCalc;
  195.      property Tag : integer read FTag;
  196.   public
  197.      constructor Create
  198.      (DaytypeDef : TDaytypeDef);
  199.      procedure Update(DaytypeDef : TDaytypeDef; StartUserId : word);
  200.      procedure SetId(AnId : word);
  201.   end;
  202.  
  203.  
  204.   TWeekDay = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday,
  205.   Saturday);
  206.   TWeekHolidays = set of TWeekDay;
  207.   {To adjust the Kronos component to countryspesific settings the user
  208.   can choose between to strategies:
  209.  
  210.   1: In the Form's constructor either load a
  211.      calendar profile from file (LoadFromFile) or call the methods :
  212.    * AddDaytype to define country spesific daytypes
  213.    * SpecifyStandardDay to name the std church and common daytypes and
  214.      set their status
  215.    * SetFirstWeekday to set the day that starts the week.
  216.    * UpdateInfo to aussure that the current info is properly updated
  217.  
  218.   2: Derive a new componet based on Kronos and override the method
  219.    SetCountrySpecifics. Here the user should call the above
  220.    mentioned methods except UpdateInfo.}
  221.  
  222.   // Event classification type. Use to iterate over the event buffer
  223.   TOcEVent = (ocYear, ocMonth, ocMonthnumber, ocWeek,
  224.   ocWeeknumber, ocMonthDay, ocWeekday, ocDate, ocToday, ocCalcDaytype);
  225.  
  226.   // Event types
  227.   TCalcDaytypeEvent = procedure(Sender : TObject; Daytype : TDaytype;
  228.   ADateExt : TDateExt; IsCurrentDate : boolean;
  229.   var Accept : boolean) of object;
  230.  
  231.   TLoadDaytypeEvent = procedure(Sender : TObject;
  232.   DaytypeDef : TDaytypeDef; var LoadIt : boolean) of object;
  233.  
  234.   TSaveDaytypeEvent = procedure(Sender : TObject;
  235.   Daytype : TDaytype; var SaveIt : boolean) of object;
  236.  
  237.   TKronos = class(TComponent)
  238.   private
  239.     { Private declarations }
  240.  
  241.     // Property fields
  242.     FYear : word;
  243.     FMonth : word;
  244.     FMonthDay : word;
  245.     FWeek : word;
  246.     FDayNumber : word;
  247.     FYearExt : TYearExt;
  248.     FMonthExt : TMonthExt;
  249.     FWeekExt : TWeekExt;
  250.     FDateExt : TDateExt;
  251.     FDayTypeCount : word;
  252.     FWeekDay : TWeekDay;
  253.     FWeekHolidays : TWeekHolidays;
  254.     FFirstWeekDay : TWeekday;
  255.     FMinYear, FMaxYear : word;
  256.     FDefaultToPresentDay : boolean;
  257.     FAllowUserCalc : boolean;
  258.     FHidePredefineds : boolean;
  259.     FFirstUserId : word;
  260.  
  261.     // Internal fields
  262.     FEventsDisabled : boolean;
  263.     {True if event triggering is disabled}
  264.     FCalcDisabled : boolean;
  265.     {True if user calc computing is disabled}
  266.     FSavedYear : word;
  267.     {Year saved with the SaveCD method}
  268.     FSavedDayNumber : word;
  269.     {Daynumber saved with the SaveCD method}
  270.     FIntYear : word;
  271.     {Year saved with the SaveIntCD private method}
  272.     FIntDayNumber : word;
  273.     {Daynumber saved with the SaveCD private method}
  274.     FChanging : boolean;
  275.     {True if a date transaction is active}
  276.     FEndChange : boolean;
  277.     FCalculating : boolean;
  278.     {True if calls form a OnCaculateDaytype event handler is processing}
  279.     FEventBuf : array[ocYear..ocCalcDaytype] of boolean;
  280.     {Buffer for storing events during a date transaction}
  281.     FTransYear : word;
  282.     {The year that was the current year when a date transaction started}
  283.     FTransDayNr : word;
  284.     {The daynumber that was the current daynumber when a date
  285.     transaction started}
  286.     FTransError : boolean;
  287.     {True if an error occured during a date transaction}
  288.     FCSpIndex : integer;
  289.     {The index of the IdList that is the last predefined daytype}
  290.  
  291.     // Internal calendar variables
  292.     Kron : TKron;
  293.     IntFirstWeekday : word; //First weekday of year
  294.     DayCodes : TDaycodes; //Daycodes for churchdays
  295.     ChurchdayIndex : TChurchdayIndex;
  296.     Cal : TCal;
  297.  
  298.     // Events
  299.     FOnChangeYear,
  300.     FOnChangeMonth,
  301.     FOnChangeMonthNumber,
  302.     FOnChangeWeek,
  303.     FOnChangeWeekNumber,
  304.     FOnChangeMonthDay,
  305.     FOnChangeWeekday,
  306.     FOnChangeDate,
  307.     FOnToday : TNotifyEvent;
  308.     FOnCalcDaytype : TCalcDaytypeEvent;
  309.     FOnLoadDayType : TLoadDaytypeEvent;
  310.     FOnSaveDaytype : TSaveDaytypeEvent;
  311.  
  312.     // Property setting procedures
  313.     procedure SetYear (Value : word);
  314.     procedure SetMonth (Value : word);
  315.     procedure SetMonthDay (Value : word);
  316.     procedure SetDayNumber (Value : word);
  317.     procedure SetWeek (Value : word);
  318.     procedure SetWeekDay(Value : TWeekDay);
  319.     procedure SetFirstWeekDay(Value : TWeekday);
  320.     procedure SetWeekHolidays(Value : TWeekHolidays);
  321.     procedure SetMinYear(Value : word);
  322.     procedure SetMaxYear(Value : word);
  323.     procedure SetHidePredefineds(Value : boolean);
  324.  
  325.     procedure SetYearExt;
  326.     procedure SetMonthExt;
  327.     procedure SetWeekExt;
  328.     procedure SetDateExt(AYear, AMonth, AMonthDay, ADaynr : word;
  329.     ACal : TCal; ADayC : TDaycodes);
  330.  
  331.     {Sets default attributes of standard churchdays and common days}
  332.     procedure SetDefaults;
  333.     //procedure SetCommonDaysDate;
  334.  
  335.     {Low level internal routines operating on the basic
  336.     calendar structures}
  337.     function SeekDate(MonthDate: Word; Leap : Boolean) : Word;
  338.     procedure MakeKron(AYear : word);
  339.     procedure SetFirstDay(AYear: Word; var F : Integer);
  340.     procedure MakeDates(AYear : Word; var CalTab : TCal);
  341.     procedure SetFixedCodes(AYear : Integer);
  342.     procedure SetRelCodes(FullMoonDate:Integer);
  343.     procedure MakeCal(AYear:Integer);
  344.  
  345.     //High level internal routines
  346.     function GetDayType(AnIndex : word) : TDaytype;
  347.     function GetMonthImage : TMonthImage;
  348.     function FindDayType(DayTypeName : string) : word;
  349.     function FindDayTypeId(DayTypeId : word) : word;
  350.     procedure FindOffsetDay(var TheYear, TheDayNumber : word;
  351.     OffsetValue : integer; WorkdaysOnly : Boolean);
  352.     procedure FindOffsetWeek(var TheYear, TheDayNumber : word;
  353.     OffsetValue : integer);
  354.     procedure FindOffsetMonth(var TheYear, TheDayNumber : word;
  355.     OffsetValue : integer);
  356.  
  357.     {Other internal routines}
  358.     function ConvertWeekday(DayOfWeekNumber : word) : TWeekDay;
  359.     procedure SaveIntCD;
  360.     procedure RestoreIntCd;
  361.     function GetDOW(DNr : word) : word;
  362.     function ShowUp(F,L,Sf,Y : word) : boolean;
  363.  
  364.   protected
  365.     { Protected declarations }
  366.  
  367.     {User daytype definitions. Three level index. The object fields
  368.     references a TDaytype object}
  369.  
  370.     Datelist : TStringList;
  371.     {Date sort. 4 digit string
  372.     Fixed dates:
  373.     0101 = jan. 1., 0102, jan 2., etc
  374.     Dates relative to churchdays:
  375.     0100
  376.     User calculated dates:
  377.     0010
  378.     Yeartypes:
  379.     0000}
  380.  
  381.     NameList : TStringList;
  382.     {Name sort}
  383.  
  384.     IdList : TStringList;
  385.     {Id sort. 6 digit string (000001 = 1, etc}
  386.  
  387.     NextId : word;
  388.     {Next id to be assigned to a userdefined daytype}
  389.  
  390.     procedure DisableIndexing(Disable : boolean);
  391.     {Turns off sorting (Disable = true for all lists).
  392.     Used in connection with loading from file, to speed up daytype creation.
  393.     Call with Disable = false to turn on indexing and resort the lists}
  394.  
  395.     procedure Loaded; override;
  396.     procedure SetCountrySpecifics; virtual;
  397.     procedure ChangeYear; dynamic;
  398.     procedure ChangeMonth; dynamic;
  399.     procedure ChangeMonthNumber; dynamic;
  400.     procedure ChangeWeek; dynamic;
  401.     procedure ChangeWeekNumber; dynamic;
  402.     procedure ChangeMonthDay; dynamic;
  403.     procedure ChangeWeekday; dynamic;
  404.     procedure ChangeDate; dynamic;
  405.     procedure Today; dynamic;
  406.     procedure CalcDaytype(Daytype : TDaytype; ADateExt : TDateExt;
  407.     IsCurrentDate : boolean; var Accepted : boolean); dynamic;
  408.     procedure LoadDaytype(DaytypeDef : TDaytypeDef;
  409.     var LoadIt : boolean); dynamic;
  410.     procedure SaveDaytype(Daytype : TDaytype;
  411.     var SaveIt : boolean); dynamic;
  412.  
  413.     {Functions operating directly on the internal calendar structures:}
  414.     procedure ChangeKron(AYear : word);
  415.     {Changes the internal calendar to AYear}
  416.     function ReadYear : TYear;
  417.     {Reads year information}
  418.     function ReadDay(DNr : word) : TDay;
  419.     {Reads day information}
  420.     function ReadWeek(WNr : word) : TWeek;
  421.     {Reads week information}
  422.     function ReadMonth(MNr : word) : TMonth;
  423.     {Reads month information}
  424.     function ReadDayNr(ADate : word) : word;
  425.     {Reads daynumber. ADate = Month * 100 + Monthday}
  426.  
  427.     procedure DisableUserCalc(Disable : boolean);
  428.     {Disables user calculation of daytypes, i.e. disables triggering
  429.     of the OnCalcDaytype event}
  430.     procedure ClearLists;
  431.     {Clears the daytype lists, except the predefined daytypes}
  432.     function GetDaytypeObject(AnId : word; AName : string) : TDaytype;
  433.     {Retrievs a daytype from the daytype list}
  434.  
  435.   public
  436.     { Public declarations }
  437.  
  438.     Daynames : array[1..7] of string;
  439.     Monthnames : array[1..12] of string;
  440.  
  441.     constructor Create(AOwner : TComponent); override;
  442.     destructor Destroy; override;
  443.  
  444.     //Configuration methods
  445.     function AddDaytype(DayType: TDaytype) : Word;
  446.     {Add one user defined spesific day to the daytype list}
  447.     procedure ClearUserDaytypes;
  448.     {Clears all user defined spesific days from the daytype list,
  449.     except the ones prefefined}
  450.     procedure DeleteUserDayType(AnId : word; AName : string);
  451.     {Deletes a user daytype}
  452.     procedure UpdateDaytype(AnId : word; AName : string;
  453.     DaytypeDef : TDaytypeDef);
  454.     {Changes the definition of a user daytype}
  455.     function GetDaytypeDef(AnId : word; AName : string) : TDaytypeDef;
  456.     {Retrieves a user daytype definition}
  457.     function GetNextDaytype(var NextIndex : word) : TDaytype;
  458.     {Retrievs a daytype from the daytype list}
  459.     procedure SpecifyStandardDay(AnId : word; AName : string;
  460.     IsHoliday, IsFlagday : boolean);
  461.     {Specifies the standard predefined days with native names and status}
  462.     procedure LoadFromFile(AFilename : string; LoadAll : boolean);
  463.     {Loads a calendar definition from file}
  464.     procedure SaveToFile(AFilename : string);
  465.     {Saves a calendar definition to file}
  466.  
  467.     //Stores information about the current date
  468.     property YearExt : TYearExt read FYearExt;
  469.     property MonthExt : TMonthExt read FMonthExt;
  470.     property WeekExt : TWeekExt read FWeekExt;
  471.     property DateExt : TDateExt read FDateExt;
  472.     property DayTypeCount : word read FDayTypeCount;
  473.     property DayTypes[AnIndex : word] : TDaytype read GetDayType;
  474.     property FirstUserId : Word read FFirstUserId;
  475.  
  476.     //Fetches information without changing the current day
  477.     function FetchYearExt(AYear : word) : TYearExt;
  478.     function FetchMonthExt(AYear, AMonth : word) : TMonthExt;
  479.     function FetchWeekExt(AYear, AWeek : word ) : TWeekExt;
  480.     function FetchDateExt(AYear, AMonth, AMonthDay : word) : TDateExt;
  481.     function FetchDateExtDt(ADate : TDateTime) : TDateExt;
  482.     function FetchDateExtDn(AYear, ADayNumber : word) : TDateExt;
  483.     function FetchDaytype(ADateExt : TDateExt; AnIndex : word) : TDaytype;
  484.     function FetchYeartype(AYearExt : TYearExt; AnIndex : word) : TDaytype;
  485.     function IsLeapYear(AYear : word) : boolean;
  486.     function IsLastDayOfMonth(AYear, AMonth, AMonthDay : word) : boolean;
  487.     function IsLastWeekOfYear(AYear, AWeek : word) : boolean;
  488.  
  489.     //Interval functions
  490.     function MonthsInInterval(Year1, Month1, Year2, Month2: word) : integer;
  491.     {Calculates the number of months between 1 and 2}
  492.     function WeeksInInterval(Year1, Week1, Year2, Week2: word) : integer;
  493.     {Calculates the number of weeks between 1 and 2}
  494.     function DaysInInterval(Year1, Month1, MonthDay1,
  495.     Year2, Month2, MonthDay2 : word; WorkdaysOnly : boolean) : integer;
  496.     {Calculates the number of days between 1 and 2}
  497.     function DaysInIntervalDn(Year1, Daynumber1, Year2, Daynumber2 : word;
  498.     WorkdaysOnly : boolean) : integer;
  499.     function DaysInIntervalDt(Date1, Date2 : TDateTime;
  500.     WorkdaysOnly : boolean) : integer;
  501.  
  502.     //Search- and offset calculating procedures
  503.     function DaynumberByTypeName(AYear : word; DayTypeName : string) : word;
  504.     {Returns the daynumber in AYear that contains Daytypename}
  505.     function DaynumberByTypeId(AYear : word; ADayTypeId : word) : word;
  506.     {Returns then daynumber in AYear that matches a DaytypeId}
  507.     procedure DateByDayOffset(var TheYear, TheDayNumber : word;
  508.     OffsetValue : integer; WorkdaysOnly : Boolean);
  509.     {Returns the year and daynumber by counting offsetvalue days from
  510.     current date}
  511.     procedure DateByWeekOffset(var TheYear, TheDayNumber : word;
  512.     OffsetValue : integer);
  513.     {Returns the year and daynumber by counting offsetvalue weeks from
  514.     current date}
  515.     procedure DateByMonthOffset(var TheYear, TheDayNumber : word;
  516.     OffsetValue : integer);
  517.     {Returns the year and daynumber by counting offsetvalue months from
  518.     current date}
  519.  
  520.     //Retrievs information about the current date
  521.     function IsToday(var AYear, ADayNumber : word) : boolean;
  522.     function IsTomorrow(var AYear, ADayNumber : word) : boolean;
  523.     function IsYesterday(var AYear, ADayNumber : word) : boolean;
  524.     function IsThisWeek(var AYear, AWeekNumber : word) : boolean;
  525.     function IsNextWeek(var AYear, AWeekNumber : word) : boolean;
  526.     function IsLastWeek(var AYear, AWeekNumber : word) : boolean;
  527.     function IsThisMonth(var AYear, AMonthNumber : word) : boolean;
  528.     function IsNextMonth(var AYear, AMonthNumber : word) : boolean;
  529.     function IsLastMonth(var AYear, AMonthNumber : word) : boolean;
  530.     function IsThisYear(var AYear : word) : boolean;
  531.     function IsNextYear(var AYear : word) : boolean;
  532.     function IsLastYear(var AYear : word) : boolean;
  533.  
  534.     //Changes the current date by calculating or searching
  535.     procedure GotoDate(AYear, AMonth, AMonthDay : word);
  536.     procedure GotoDateDt(ADate : TDateTime);
  537.     procedure GotoDateDn(AYear, ADayNumber : word);
  538.     procedure GotoToday;
  539.     procedure GotoTomorrow;
  540.     procedure GotoYesterday;
  541.     procedure GotoThisWeek;
  542.     procedure GotoNextWeek;
  543.     procedure GotoLastWeek;
  544.     procedure GotoThisMonth;
  545.     procedure GotoNextMonth;
  546.     procedure GotoLastMonth;
  547.     procedure GotoDayType(AYear : word; AnId : word; DayTypeName : string);
  548.     {Moves to the daynumber in AYear that contains Daytypename/id}
  549.     procedure GoToOffsetDay(OffsetValue : integer;
  550.     WorkdaysOnly : boolean);
  551.     {Moves to Year/Daynumber that results from the number of days in
  552.     OffsetValue. Startingpoint is current date}
  553.     procedure GoToOffsetWeek(OffsetValue : integer);
  554.     {Moves to Year/Daynumber that results from the number of weeks in
  555.     OffsetValue. Startingpoint is current date}
  556.     procedure GoToOffsetMonth(OffsetValue : integer);
  557.     {Moves to Year/Daynumber that results from the number of months in
  558.     OffsetValue. Startingpoint is current date}
  559.  
  560.     //Converting functions
  561.     function DOWtoWeekday(ADayOfWeekNumber : word) : TWeekDay;
  562.     {Converts a day of week number to a TWeekday type}
  563.     function DOWtoDayNameIndex(ADayOfWeekNumber:word) : word;
  564.     {Converts a day of week number to an index that can be used to
  565.     access Daynames array}
  566.     function CDtoDateTime : TDateTime;
  567.     {Converts the current date to Datetime-format}
  568.  
  569.     //Functions operating on MonthImage
  570.     procedure GetMIDayCell(ADayNumber : word; var ARow, ACol : Longint);
  571.     {Returns the row and column in the current MonthImage that contains
  572.     ADaynumber}
  573.     function GetMIWeekRow(AWeekNumber : word) : word;
  574.     {Returns the row in the current MonthImage that contains
  575.     AWeekNumber}
  576.     procedure GetFirstMIDayCell(var ARow, ACol : Longint);
  577.     {Returns the row and column in the current MonthImage that contains
  578.     the first daynumber}
  579.     procedure GetLastMIDayCell(var ARow, ACol : Longint);
  580.     {Returns the row and column in the current MonthImage that contains
  581.     the last daynumber}
  582.  
  583.     //Misc
  584.     procedure DisableEvents(Disable : boolean);
  585.     {Turns off event triggering}
  586.     procedure SaveCD;
  587.     {Saves the current date}
  588.     procedure RestoreCD;
  589.     {Restores the current date}
  590.     procedure UpdateInfo;
  591.     {Updates ext-properties with latest changes}
  592.     procedure BeginChange;
  593.     {Starts a date transaction}
  594.     procedure EndChange;
  595.     {Ends a date transaction}
  596.     function ExistsDaytype(DaytypeName : string) : Word;
  597.     {Checks for duplicate daytype names}
  598.     procedure Rechange;
  599.     {Retriggers all change eventhandlers}
  600.  
  601.   published
  602.     { Published declarations }
  603.     property Year : word read FYear write SetYear;
  604.     property Month : word read FMonth write SetMonth;
  605.     property MonthDay : word read FMonthDay write SetMonthDay;
  606.     property FirstWeekDay : TWeekDay read FFirstWeekday
  607.        write SetFirstWeekday;
  608.     property WeekDay : TWeekDay read FWeekDay write SetWeekDay;
  609.     property Week : word read FWeek write SetWeek;
  610.     property DayNumber : word read FDayNumber write SetDayNumber;
  611.     property WeekHolidays : TWeekHolidays read FWeekHolidays
  612.        write SetWeekHolidays;
  613.     property DefaultToPresentDay : boolean read FDefaultToPresentDay
  614.        write FDefaultToPresentDay;
  615.     property MinYear : word read FMinYear write SetMinYear;
  616.     property MaxYear : word read FMaxYear write SetMaxYear;
  617.     property AllowUserCalc : boolean read FAllowUserCalc
  618.        write FAllowUserCalc;
  619.     property HidePredefineds : boolean read FHidePredefineds
  620.        write SetHidePredefineds;
  621.  
  622.     property OnChangeYear : TNotifyEvent read FOnChangeYear
  623.        write FOnChangeYear;
  624.     property OnChangeMonth : TNotifyEvent read FOnChangeMonth
  625.        write FOnChangeMonth;
  626.     property OnChangeMonthNumber : TNotifyEvent read FOnChangeMonthNumber
  627.        write FOnChangeMonthNumber;
  628.     property OnChangeWeek : TNotifyEvent read FOnChangeWeek
  629.        write FOnChangeWeek;
  630.     property OnChangeWeekNumber : TNotifyEvent read FOnChangeWeekNumber
  631.        write FOnChangeWeekNumber;
  632.     property OnChangeMonthDay : TNotifyEvent read FOnChangeMonthDay
  633.        write FOnChangeMonthDay;
  634.     property OnChangeWeekDay : TNotifyEvent read FOnChangeWeekDay
  635.        write FOnChangeWeekDay;
  636.     property OnChangeDate : TNotifyEvent read FOnChangeDate
  637.        write FOnChangeDate;
  638.     property OnToday : TNotifyEvent read FOnToday
  639.        write FOnToday;
  640.     property OnCalcDaytype : TCalcDaytypeEvent read FOnCalcDaytype
  641.        write FOnCalcDaytype;
  642.     property OnLoadDaytype : TLoadDaytypeEvent read FOnLoadDaytype
  643.        write FOnLoadDaytype;
  644.     property OnSaveDaytype : TSaveDaytypeEvent read FOnSaveDaytype
  645.        write FOnSaveDaytype;
  646.   end;
  647.  
  648.   EKronosError = class(Exception);
  649.  
  650. procedure Register;
  651.  
  652. implementation
  653.  
  654. const
  655.      // Error messages
  656.      c_YearOutOfBounds = 'Year out of bounds';
  657.      c_MonthOutOfBounds = 'Month out of bounds';
  658.      c_WeekOutOfBounds = 'Week out of bounds';
  659.      c_MonthdayOutOfBounds = 'Monthday out of bounds';
  660.      c_DaynumberOutOfBounds = 'Daynumber out of bounds';
  661.      c_DayOfWeekNumberOutOfBounds = 'DayOfWeekNumber out of bounds';
  662.      c_ShowFreqTooBig = 'Showup frequency too big';
  663.      c_MinYearOutofBounds = 'Min year out of bounds';
  664.      c_MaxYearOutofBounds = 'Max year out of bounds';
  665.      c_MinYearOutofCurrentYear = 'Cannot set. ' +
  666.      'Value of MinYear conflicts with current year';
  667.      c_MaxYearOutofCurrentYear = 'Cannot set. ' +
  668.      'Value of MaxYear conflicts with current year';
  669.      c_DaytypeIndexOutOfRange = 'Daytype index out of range';
  670.      c_DuplicateName = 'Duplicate daytype name';
  671.      c_TooManyDaytypes = 'Too many daytypes';
  672.      c_CannotDeleteStableDaytype = 'Cannot delete stable daytype';
  673.  
  674.  
  675. procedure Register;
  676. begin
  677.   RegisterComponents('Samples', [TKronos]);
  678. end;
  679.  
  680.  
  681. {*************************** Local procs *****************************}
  682.  
  683. procedure GetDate(var Aar, Month, Day, Wd : word);
  684. var
  685.    D : TDateTime;
  686. begin
  687.      D := Date;
  688.      DecodeDate(D, Aar, Month, Day);
  689.      Wd := DayOfWeek(D);
  690. end;
  691.  
  692. function IsLeap(aar : Integer) : Boolean;
  693. // Check for leapyear
  694.  
  695. begin
  696.    Result := false;
  697.    Result := (aar mod 4 = 0) and (aar mod 100 = 0) and (aar mod 400 = 0);
  698.    if Result then exit;
  699.    if (aar mod 4 = 0) and (aar mod 100 = 0) then exit;
  700.    Result := (aar mod 4 = 0);
  701. end; {IsLeap}
  702.  
  703.  
  704. {************************** TDaytype methods ****************************}
  705.  
  706. constructor TDaytype.Create;
  707. begin
  708.      inherited Create;
  709.      with DaytypeDef do
  710.      begin
  711.           FName := AName;
  712.           FDate := ADate;
  713.           FRelDaytype := ARelDayType;
  714.           FOffset := AnOffset;
  715.           FFirstShowUp := AFirstShowUp;
  716.           FLastShowUp := ALastShowUp;
  717.           FShowUpFrequency:= AShowUpFrequency;
  718.           FChurchday := AChurchDay;
  719.           FHoliday := AHoliday;
  720.           FFlagDay := AFlagday;
  721.           FUserCalc := AUserCalc;
  722.           FTag := ATag;
  723.      end;
  724. end;
  725.  
  726. procedure TDayType.Update;
  727. begin
  728.      with DaytypeDef do
  729.      begin
  730.           FName := AName;
  731.           if FId >= StartUserId then
  732.           {These proerties not etidable for predefined daytypes:}
  733.           begin
  734.              FDate := ADate;
  735.              FRelDayType := ARelDaytype;
  736.              FOffset := AnOffset;
  737.              FFirstShowUp := AFirstShowUp;
  738.              FLastShowUp := ALastShowUp;
  739.              FShowUpFrequency := AShowUpFrequency;
  740.              FUserCalc := AUserCalc;
  741.              FTag := ATag;
  742.           end;
  743.           FChurchDay := AChurchDay;
  744.           FHoliday := AHoliday;
  745.           FFlagday := AFlagday;
  746.      end;
  747. end;
  748.  
  749. procedure TDaytype.SetId;
  750. begin
  751.      FId := AnId;
  752. end;
  753.  
  754. {*************************** TKronos methods **************************}
  755.  
  756. constructor TKronos.Create;
  757. var
  758.    Y, M, D, Wd : word;
  759. begin
  760.      inherited Create(AOwner);
  761.      DateList := TStringList.Create;
  762.      DateList.Sorted := true;
  763.      DateList.Duplicates := dupAccept;
  764.      NameList := TStringlist.Create;
  765.      NameList.Sorted := true;
  766.      NameList.Duplicates := dupAccept;
  767.      IdList := TStringlist.Create;
  768.      IdList.Sorted := true;
  769.      IdList.Duplicates := dupError;
  770.      NextId := 1;
  771.      SetDefaults;
  772.      SetCountrySpecifics;
  773.      FCSpIndex := DateList.Count - 1;
  774.      FFirstUserId := FCspIndex + 2;
  775.      FDefaultToPresentDay := true;
  776.      GetDate(Y, M, D, Wd);
  777.      dec(Wd);
  778.      if Wd = 0 then
  779.         Wd := 7;
  780.      MakeKron(Y);
  781.      FirstWeekDay := Sunday;
  782.      FYear := Y;
  783.      FMonth := M;
  784.      FMonthDay := D;
  785.      FDayNumber := ReadDayNr(M * 100 + D);
  786.      FWeekDay := ConvertWeekday(Wd);
  787.      FWeekHolidays := [Saturday, Sunday];
  788.      FMaxYear := 9999;
  789.      FMinYear := 1;
  790.  
  791.      IntFirstWeekday := Ord(FFirstWeekday);
  792.      if IntFirstWeekday = 0 then IntFirstWeekday := 7;
  793.  
  794.      SetYearExt;
  795.      SetMonthExt;
  796.      SetDateExt(0,0,0,0, Cal, DayCodes);
  797.      FWeek := FDateExt.WeekNumber;
  798.      SetWeekExt;
  799.      FEventsDisabled := false;
  800. end;
  801.  
  802. procedure TKronos.Loaded;
  803. var
  804.    Y, M, D, Wd : word;
  805. begin
  806.      inherited Loaded;
  807.  
  808.      GetDate(Y, M, D, Wd);
  809.      if FDefaultToPresentDay then
  810.      begin
  811.           if Kron.ActiveYear <> Y then
  812.              ChangeKron(Y);
  813.           dec(Wd);
  814.           if Wd = 0 then
  815.              Wd := 7;
  816.           FYear := Y;
  817.           FMonth := M;
  818.           FMonthDay := D;
  819.           FDayNumber := ReadDayNr(M * 100 + D);
  820.           FWeekDay := ConvertWeekday(Wd);
  821.      end
  822.      else
  823.      begin
  824.           if FYear <> Kron.ActiveYear then
  825.              ChangeKron(FYear);
  826.      end;
  827.  
  828.      SetYearExt;
  829.      SetMonthExt;
  830.      SetDateExt(0,0,0,0, Cal, DayCodes);
  831.      FWeek := FDateExt.WeekNumber;
  832.      SetWeekExt;
  833. end;
  834.  
  835. destructor TKronos.Destroy;
  836. var
  837.    i : integer;
  838. begin
  839.      for i := 0 to DateList.Count - 1 do
  840.          DateList.Objects[i].Free;
  841.      DateList.Free;
  842.      NameList.Free;
  843.      IdList.Free;
  844.      inherited Destroy;
  845. end;
  846.  
  847. function TKronos.SeekDate;
  848. {Seeks a date in the internal calendar. Binary search}
  849. var
  850.    First,Last,Current,TestMonthDate : word;
  851.    Found, Stop : boolean;
  852. begin
  853.      if Leap then Last := 366 else Last := 365;
  854.      First := 1;
  855.      Current := Last div 2;
  856.      TestMonthDate := Cal[Current];
  857.      Stop := TestMonthDate = MonthDate;
  858.      Found := Stop;
  859.      while not stop do
  860.      begin
  861.           if MonthDate < TestMonthDate then Last := Current - 1
  862.           else First := Current + 1;
  863.           Current := (Last + First) div 2;
  864.           TestMonthDate := Cal[Current];
  865.           Found := TestMonthDate = MonthDate;
  866.           Stop := Found or (First >= Last)
  867.      end;
  868.      if not Found then Result := 0
  869.      else Result := Current;
  870. end;
  871.  
  872. {** The following procedures loads the basic information structures*****}
  873.  
  874. function TKronos.ReadYear : TYear;
  875. // Load Year-info
  876. var
  877.    YearNumber : word;
  878.    TheYear : TYear;
  879.    I : integer;
  880.    StartWeekday, EndWeekday : integer;
  881. begin
  882.    YearNumber := Kron.ActiveYear;
  883.    with TheYear do
  884.      begin
  885.      If IsLeap(YearNumber) then
  886.         Daycount := 366
  887.      else
  888.         Daycount := 365;
  889.      I := 0;
  890.      repeat
  891.         inc(I);
  892.         if DayCodes[I,1] = IntFirstWeekday then
  893.            StartWeekday := I;
  894.      until (DayCodes[I,1] = IntFirstWeekday);
  895.  
  896.      I := Daycount + 1;
  897.      repeat
  898.         dec(I);
  899.         if DayCodes[I,1] = IntFirstWeekday then
  900.            EndWeekday := I;
  901.      until (DayCodes[I,1] = IntFirstWeekday);
  902.      WeekCount := (EndWeekday - StartWeekday) div 7;
  903.      //Number of whole weeks
  904.      if StartWeekday > 1 then inc(WeekCount);
  905.      //Week nr 1, rest of last year
  906.      if (EndWeekday + 7) >  Daycount then inc(WeekCount);
  907.      //Unterminated week at end of year
  908.  
  909.    end;
  910.    Result := TheYear;
  911. end;
  912.  
  913. function TKronos.ReadDay(DNr : word) : TDay;
  914. // Load Day-info
  915. var
  916.    FirstDay : Integer;
  917.    Day : TDay;
  918.    I, StartWeek : integer;
  919.    TheYear : TYear;
  920.    StartWeekday, EndWeekday : integer;
  921. begin
  922.  
  923.   with Day do begin
  924.      Daynum := DNr;
  925.  
  926.      MonthDate := Cal[Daynum];
  927.      Month := MonthDate div 100;
  928.      DOWNum := DayCodes[Daynum,1];
  929.      DayCode := DayCodes[Daynum,2];
  930.      TheYear := ReadYear;
  931.      I := 0;
  932.      repeat
  933.         inc(I);
  934.         if DayCodes[I,1] = IntFirstWeekday then
  935.            StartWeekday := I;
  936.      until (DayCodes[I,1] = IntFirstWeekday);
  937.  
  938.      I := TheYear.Daycount + 1;
  939.      repeat
  940.         dec(I);
  941.         if DayCodes[I,1] = IntFirstWeekday then
  942.            EndWeekday := I;
  943.      until (DayCodes[I,1] = IntFirstWeekday);
  944.  
  945.      if (DNr < StartWeekday) then
  946.         Week := 1
  947.      else if DNr >= EndWeekday then
  948.           Week := TheYear.WeekCount
  949.      else
  950.      begin
  951.        StartWeek := 2;
  952.        I := StartWeekday;
  953.        if StartWeekday = 1 then
  954.           StartWeek := 1;
  955.        Week := 0;
  956.        repeat
  957.              inc(I, 7);
  958.              if DNr < I then
  959.              begin
  960.                   Week := StartWeek;
  961.                   break;
  962.              end;
  963.              inc(StartWeek);
  964.        until Week = StartWeek;
  965.      end;
  966.   end;
  967.  
  968.   Result := Day;
  969. end;
  970.  
  971. function TKronos.ReadWeek;
  972. // Load Week-info
  973. var
  974.    i, StartWeekday : Word;
  975.    Week : TWeek;
  976.    WeekNumber, WeekCount : integer;
  977.    TheYear : TYear;
  978.    Stop : boolean;
  979.  
  980. begin
  981.    TheYear := ReadYear;
  982.    WeekNumber := Wnr;
  983.    with Week do
  984.    begin
  985.      i := 0;
  986.      repeat
  987.            inc(i);
  988.            if DayCodes[i,1] = IntFirstWeekday then StartWeekday := i;
  989.      until DayCodes[i,1] = IntFirstWeekday;
  990.      if (WeekNumber = 1) and (StartWeekday = 1) then
  991.      begin
  992.           WhichDays[1] := 1;
  993.           WhichDays[2] := 7;
  994.      end
  995.      else if (WeekNumber = 1) then
  996.      begin
  997.           WhichDays[1] := 1;
  998.           WhichDays[2] := StartWeekday - 1;
  999.      end
  1000.      else
  1001.      begin
  1002.           I := StartWeekday;
  1003.           if I = 1 then
  1004.              WeekCount := 1
  1005.           else
  1006.              WeekCount := 2;
  1007.           Stop := false;
  1008.           repeat
  1009.                 if (WeekCount = WeekNumber) then
  1010.                 begin
  1011.                      WhichDays[1] := I;
  1012.                      if WeekCount = TheYear.WeekCount then
  1013.                         WhichDays[2] := TheYear.Daycount
  1014.                      else
  1015.                         WhichDays[2] := I + 6;
  1016.                      Stop := true;
  1017.                 end;
  1018.                 inc(I, 7);
  1019.                 inc(WeekCount);
  1020.           until Stop;
  1021.      end;
  1022.    end;
  1023.    Week.WeekNum := WNr;
  1024.    Result := Week;
  1025. end;
  1026.  
  1027. function TKronos.ReadMonth;
  1028. // Load MonthInfo
  1029. var
  1030.    I,Rest : Integer;
  1031.    WeekNum : Integer;
  1032.    FirstDay : Integer;
  1033.    Mnd : TMonth;
  1034.    Day : TDay;
  1035. begin
  1036.    with Mnd do
  1037.    begin
  1038.      if Mnr In[1, 3, 5, 7, 8, 10, 12] then Daycount := 31
  1039.      else if Mnr = 2 then
  1040.      begin
  1041.          if IsLeap(Kron.ActiveYear) then Daycount := 29
  1042.          else Daycount := 28;
  1043.      end
  1044.      else Daycount := 30;
  1045.      i := 0;
  1046.      repeat inc(i) until (Cal[i] div 100 = MNr);
  1047. {->  First Day of month}
  1048.      WhichDays[1] := i;
  1049.      WhichDays[2] := i + Daycount - 1;
  1050.      i := 0;
  1051.      repeat inc(i) until (DayCodes[i,1] = IntFirstWeekday);
  1052. {->  Daynumber of first weekday}
  1053.  
  1054.      Day := ReadDay(WhichDays[1]);
  1055.      WhichWeeks[1] := Day.Week;
  1056.      Day := ReadDay(WhichDays[2]);
  1057.      WhichWeeks[2] := Day.Week;
  1058.      WeekCount := WhichWeeks[2] - WhichWeeks[1] + 1;
  1059.    end;
  1060.    Result := Mnd;
  1061. end;
  1062.  
  1063. function TKronos.ReadDayNr;
  1064. {Returns Daynumber tied to MonthDate}
  1065. begin
  1066.      Result := SeekDate(ADate,IsLeap(Kron.ActiveYear));
  1067. end;
  1068.  
  1069. procedure TKronos.MakeKron;
  1070. begin
  1071.      Kron.ActiveYear := AYear;
  1072.      MakeCal(AYear);
  1073.      Kron.IsInitialized := true;
  1074. end;
  1075.  
  1076. procedure TKronos.ChangeKron;
  1077. begin
  1078.      MakeKron(AYear);
  1079. end;
  1080.  
  1081. {********Procedures to create the internal calendar for a year *************}
  1082.  
  1083. procedure TKronos.SetFirstDay;
  1084. {Computes first weekday of yaer}
  1085.  
  1086. var
  1087.    m,d : word;
  1088.    T : TDateTime;
  1089.    DOW : word;
  1090.  
  1091. begin
  1092.     m := 1; d := 1;
  1093.     T := EncodeDate(AYear,m,d);
  1094.     DOW := DayOfWeek(T);
  1095.     dec(DOW);
  1096.     if DOW = 0 then DOW := 7;
  1097.     f := DOW;
  1098. end;
  1099.  
  1100. procedure TKronos.MakeDates;
  1101. {Fills the calendar table with dates}
  1102.  
  1103. var
  1104. i, j, l, MonthDays : Integer;
  1105.  
  1106. begin
  1107.       l := 0;
  1108.       for i := 1 to 12 do
  1109.       begin
  1110.          if i in[1, 3, 5, 7, 8, 10, 12] then MonthDays := 31
  1111.          else if i = 2 then
  1112.          begin
  1113.             if IsLeap(AYear) then MonthDays := 29
  1114.             else MonthDays := 28;
  1115.          end
  1116.          else MonthDays := 30;
  1117.          for j := 1 to MonthDays do
  1118.          begin
  1119.             inc(l);
  1120.             CalTab[l] := (i * 100) + j;
  1121.          end;
  1122.       end;
  1123. end; {MakeDates}
  1124.  
  1125.  
  1126. procedure TKronos.SetFixedCodes;
  1127. {Sets DayCodes: fixed predefined churchdays}
  1128.  
  1129. var
  1130.    Christm_1,Christm_2 : Integer;
  1131.    ChristmEve, Adv : Integer;
  1132.    FirstDay, MaxDays,Daycount : Integer;
  1133.    j,i : Integer;
  1134.  
  1135. begin
  1136.    SetFirstDay(AYear, FirstDay);
  1137.    if IsLeap(AYear) then
  1138.    begin
  1139.         ChristmEve := 359;
  1140.         Christm_1 := 360;
  1141.         Christm_2 := 361;
  1142.  
  1143.         MaxDays := 366;
  1144.     end
  1145.     else
  1146.     begin
  1147.         ChristmEve := 358;
  1148.         Christm_1 := 359;
  1149.         Christm_2 := 360;
  1150.         MaxDays := 365;
  1151.     end;
  1152.  
  1153.     Daycount := 0;
  1154.     repeat
  1155.          j := FirstDay;
  1156.          i := 1;
  1157.          repeat
  1158.               inc(Daycount);
  1159.               DayCodes[Daycount,1] := j;
  1160.               // DOW-number in a Monday-first based system
  1161.  
  1162.               if (Daycount = 1) then
  1163.               begin
  1164.                    DayCodes[Daycount,2] := chNewYearDay;
  1165.                    ChurchdayIndex[chNewYearDay] := 1;
  1166.               end
  1167.               else if (Daycount = ChristmEve) then
  1168.               begin
  1169.                    DayCodes[Daycount,2] := chChristmasEve;
  1170.                    ChurchdayIndex[chChristmasEve] := Daycount;
  1171.               end
  1172.               else if (Daycount = Christm_1) then
  1173.               begin
  1174.                    DayCodes[Daycount,2] := chChristmasday;
  1175.                    ChurchdayIndex[chChristmasDay] := Daycount;
  1176.               end
  1177.               else if (Daycount = Christm_2) then
  1178.               begin
  1179.                    ChurchdayIndex[chBoxingDay] := Daycount;
  1180.                    DayCodes[Daycount,2] := chBoxingDay;
  1181.               end
  1182.               else if (Daycount = MaxDays) then
  1183.               begin
  1184.                    DayCodes[Daycount,2] := chNewYearEve;
  1185.                    ChurchdayIndex[chNewYearEve] := Daycount;
  1186.               end
  1187.               else DayCodes[Daycount,2] := 0;
  1188.               inc(j);
  1189.               if j = 8 then j := 1;
  1190.               inc(i);
  1191.          until (i = 8) or (Daycount = MaxDays);
  1192.    until Daycount = MaxDays;
  1193.  
  1194.    {Computes churchdays related to Christmas}
  1195.    adv := ChristmEve - 21;
  1196.    adv := adv - (7- (7 - DayCodes[adv,1]));
  1197.    {Now first sunday advent}
  1198.    DayCodes[adv,2] := chadvent1;
  1199.    ChurchdayIndex[chadvent1] := adv;
  1200.  
  1201.    DayCodes[adv+7,2] := chadvent2;
  1202.    ChurchdayIndex[chadvent2] := adv+7;
  1203.  
  1204.    DayCodes[adv+14,2] := chadvent3;
  1205.    ChurchdayIndex[chadvent3] := adv+14;
  1206.  
  1207.    DayCodes[adv+21,2] := chadvent4;
  1208.    ChurchdayIndex[chadvent4] := adv+21;
  1209.  
  1210. end;
  1211.  
  1212. procedure TKronos.SetRelCodes;
  1213. {Computes Easter and related days. Input is the Easter full moon}
  1214. var
  1215.    i : Integer;
  1216. begin
  1217.      i := 0;
  1218.      repeat inc(i) until Cal[i] = Fullmoondate;
  1219.      if DayCodes[i,1] = 7 then inc(i,4)
  1220.      else
  1221.      begin
  1222.           repeat inc(i) until DayCodes[i,1] = 7;
  1223.           dec(i,3);
  1224.      end;
  1225. {->  Day is now Maundy Thursday}
  1226.  
  1227.      DayCodes[i,2] := chMaundyThursday;
  1228.      ChurchdayIndex[chMaundyThursday] := i;
  1229.      inc(i);
  1230.      DayCodes[i,2] := chGoodFriday;
  1231.      ChurchdayIndex[chGoodFriday] := i;
  1232.      inc(i);
  1233.      DayCodes[i,2] := chEasterEve;
  1234.      ChurchdayIndex[chEasterEve] := i;
  1235.      inc(i);
  1236.      DayCodes[i,2] := chEasterSunday;
  1237.      ChurchdayIndex[chEasterSunday] := i;
  1238.      DayCodes[i-7,2] := chPalmSunday;
  1239.      ChurchdayIndex[chPalmSunday] := i-7;
  1240.      DayCodes[i+1,2] := chEasterMonday;
  1241.      ChurchdayIndex[chEasterMonday] := i+1;
  1242.      DayCodes[i+48,2] := chWhitEve;
  1243.      ChurchdayIndex[chWhitEve] := i+48;
  1244.      DayCodes[i+49,2] := chWhitSunday;
  1245.      ChurchdayIndex[chWhitSunday] := i+49;
  1246.      DayCodes[i+50,2] := chWhitMonday;
  1247.      ChurchdayIndex[chWhitMonday] := i+50;
  1248. {->  Whit}
  1249.  
  1250.      DayCodes[i-46,2] := chAshWednesday;
  1251.      ChurchdayIndex[chAshWednesday] := i-46;
  1252.      DayCodes[i-47,2] := chShroveTuesday;
  1253.      ChurchdayIndex[chShroveTuesday] := i-47;
  1254. {->  Lent}
  1255.  
  1256.      DayCodes[i+39,2] := chAscensionDay;
  1257.      ChurchdayIndex[chAscensionDay] := i+39;
  1258. {->  Ascension day}
  1259.  
  1260. end;
  1261.  
  1262. procedure TKronos.MakeCal;
  1263. {Creates a full calendar with dates and daycodes}
  1264. var
  1265.    G, C, M : integer;
  1266.    Cent : integer;
  1267.  
  1268. begin
  1269.      MakeDates(AYear,Cal);
  1270.      SetFixedCodes(AYear);
  1271.  
  1272.      // Calculates Easter full moon
  1273.      Cent := AYear div 100;
  1274.      G := (AYear mod 19) + 1;
  1275.      C := -Cent + Trunc(Cent/4) + Trunc(8*(Cent+11)/25);
  1276.      M := 50-((11*G)+ C) mod 30;
  1277.      if M > 31 then
  1278.      begin
  1279.         M := 400 + (M-31);
  1280.         if M = 419 then M := 418;
  1281.         if (M = 418) and (G >=12) then M := 417;
  1282.      end
  1283.      else
  1284.         M := 300 + M;
  1285.      SetRelCodes(M);
  1286. end;
  1287.  
  1288. procedure TKronos.SetYearExt;
  1289. var
  1290.    A : TYear;
  1291.    i : integer;
  1292.    DT : TDaytype;
  1293. begin
  1294.      A := ReadYear;
  1295.      with FYearExt do
  1296.      begin
  1297.           Year := FYear;
  1298.           NumWeeks := A.WeekCount;
  1299.           NumDays := A.Daycount;
  1300.           LeapYear := IsLeap(FYear);
  1301.           YeartypeCount := 0;
  1302.           I := 0;
  1303.           if DateList.Count = 0 then exit;
  1304.           while (i <= (DateList.Count - 1))
  1305.           and (DateList[i] = '0000') do
  1306.           begin
  1307.                DT := TDaytype(DateList.Objects[i]);
  1308.                if (DT.Id >= Userdaytype)
  1309.                and (Year >= DT.FirstShowup)
  1310.                and (Year <= DT.LastShowup)
  1311.                and ((Year - DT.FirstShowUp) mod
  1312.                DT.ShowupFrequency = 0) then
  1313.                inc(YeartypeCount);
  1314.                inc(i);
  1315.           end;
  1316.      end;
  1317. end;
  1318.  
  1319. procedure TKronos.SetMonthExt;
  1320. var
  1321.    M : TMonth;
  1322. begin
  1323.      M := ReadMonth(FMonth);
  1324.      with FMonthExt do
  1325.      begin
  1326.           Year := FYear;
  1327.           MonthNumber := FMonth;
  1328.           MonthName := Monthnames[MonthNumber];
  1329.           NumDays := M.Daycount;
  1330.           NumWeeks := M.WeekCount;
  1331.           FirstDay := M.WhichDays[1];
  1332.           LastDay := M.WhichDays[2];
  1333.           FirstWeek := M.WhichWeeks[1];
  1334.           LastWeek := M.WhichWeeks[2];
  1335.           MonthImage := GetMonthImage;
  1336.      end;
  1337. end;
  1338.  
  1339. procedure TKronos.SetWeekExt;
  1340. var
  1341.    U : TWeek;
  1342. begin
  1343.      U := ReadWeek(FWeek);
  1344.      with FWeekExt do
  1345.      begin
  1346.           Year := FYear;
  1347.           WeekNumber := FWeek;
  1348.           FirstDay := U.WhichDays[1];
  1349.           LastDay := U.WhichDays[2];
  1350.      end;
  1351. end;
  1352.  
  1353. function TKronos.ShowUp(F,L,Sf,Y : word) : boolean;
  1354. begin
  1355.         Result := false;
  1356.         if (F > 9999)
  1357.         or (L > 9999) then
  1358.            raise EKronosError.Create(c_YearOutOfBounds);
  1359.  
  1360.         if (Y < F)
  1361.         or (Y > L) then
  1362.           exit;
  1363.  
  1364.         if SF = 0 then exit;
  1365.         if SF > 9999 then
  1366.            raise EKronosError.Create(c_ShowFreqTooBig);
  1367.  
  1368.         if (Y - F) mod SF <> 0 then
  1369.           exit;
  1370.         Result := true;
  1371. end;
  1372.  
  1373.  
  1374. procedure TKronos.SetDateExt;
  1375. var
  1376.    D : TDay;
  1377.    DayType : word;
  1378.    I, Ind : integer;
  1379.    NameIndex : word;
  1380.    Wd : TWeekDay;
  1381.    Fs : word;
  1382.    Key : string;
  1383.    OldDateExt : TDateExt;
  1384.    OldCount : Word;
  1385.  
  1386.    procedure CountFixedDates(AKey : string; AnInd : integer);
  1387.    var
  1388.       DT : TDaytype;
  1389.    begin
  1390.         while (AnInd <= DateList.Count - 1)
  1391.         and (DateList[AnInd] = AKey) do
  1392.         begin
  1393.               DT := TDaytype(DateList.Objects[AnInd]);
  1394.               if FHidePredefineds and
  1395.               (DT.Id < FFirstUserId) then
  1396.               begin
  1397.                  inc(AnInd);
  1398.                  continue;
  1399.               end;
  1400.               if not ShowUp(DT.FirstShowUp,
  1401.               DT.FLastShowUp, DT.ShowUpFrequency, FYear) then
  1402.               begin
  1403.                  inc(AnInd);
  1404.                  continue;
  1405.               end;
  1406.               if FDaytypeCount = 255 then
  1407.                 raise EKronosError.Create(c_TooManyDaytypes);
  1408.  
  1409.               inc(FDayTypeCount);
  1410.               with FDateExt do
  1411.               begin
  1412.                    DaytypeId[FDayTypeCount] := DT.ID;
  1413.                    if DT.Holiday then Holiday := true;
  1414.                    if DT.Flagday then Flagday := true;
  1415.                    if DT.ChurchDay then ChurchDay := true;
  1416.               end;
  1417.               inc(AnInd);
  1418.         end;
  1419.    end;
  1420.  
  1421.    procedure CountReldays(AnInd : integer);
  1422.    //Relative to churchday
  1423.    var
  1424.       DT : TDaytype;
  1425.       TestDayNr : word;
  1426.    begin
  1427.         while (AnInd <= DateList.Count - 1)
  1428.         and (DateList[AnInd] = '0100') do
  1429.         begin
  1430.              DT := TDaytype(DateList.Objects[AnInd]);
  1431.              if FHidePredefineds and
  1432.              (DT.Id < FFirstUserId) then
  1433.              begin
  1434.                  inc(AnInd);
  1435.                  continue;
  1436.              end;
  1437.              if not ShowUp(DT.FirstShowUp,
  1438.              DT.LastShowUp, DT.ShowUpFrequency, FYear) then
  1439.              begin
  1440.                   inc(AnInd);
  1441.                   continue;
  1442.              end;
  1443.              if not (DT.ReldayType in [1..ChurchdayCount]) then
  1444.              begin
  1445.                 inc(AnInd);
  1446.                 continue;
  1447.              end;
  1448.  
  1449.              TestDayNr := ChurchdayIndex[DT.RelDayType] +
  1450.              DT.Offset;
  1451.              if TestDayNr = FDateExt.DayNumber then
  1452.              with FDateExt do
  1453.              begin
  1454.                   inc(FDayTypeCount);
  1455.                   DaytypeId[FDayTypeCount] := DT.Id;
  1456.                   if DT.Holiday then Holiday := true;
  1457.                   if DT.Flagday then Flagday := true;
  1458.                   if DT.ChurchDay then ChurchDay := true;
  1459.              end;
  1460.              inc(AnInd);
  1461.         end;
  1462.    end;
  1463.  
  1464.    procedure CountCalcdays(AnInd : integer);
  1465.    //User calculated date. Trigger the OnCalcDaytype event
  1466.    var
  1467.       DT : TDaytype;
  1468.       Accepted : boolean;
  1469.       DExt : TDateExt;
  1470.       Y : Word;
  1471.    begin
  1472.         Y := FYear;
  1473.         FDateExt.DaytypeCount := FDaytypeCount;
  1474.         if AYear <> 0 then
  1475.         {Restore to idle before calling event handler. AYear is <> 0 when
  1476.         SetDateExt is called from FetchDateExt}
  1477.         begin
  1478.              FYear := AYear;
  1479.              FMonth := AMonth;
  1480.              FMonthDay := AMonthDay;
  1481.              FDayNumber := ADayNr;
  1482.              if AYear <> Kron.ActiveYear then
  1483.              begin
  1484.                   Cal := ACal;
  1485.                   Daycodes := ADayC;
  1486.                   Kron.ActiveYear := AYear;
  1487.              end;
  1488.         end;
  1489.  
  1490.         while (AnInd <= DateList.Count - 1)
  1491.         and (DateList[AnInd] = '0010') do
  1492.         begin
  1493.              DT := TDaytype(DateList.Objects[AnInd]);
  1494.              if not ShowUp(DT.FirstShowUp,
  1495.              DT.LastShowUp, DT.ShowUpFrequency, Y) then
  1496.              begin
  1497.                   inc(AnInd);
  1498.                   continue;
  1499.              end;
  1500.  
  1501.              {Save state of FDateext}
  1502.              DExt := FDateExt;
  1503.  
  1504.              if AYear <> 0 then
  1505.              {Release idle state to user}
  1506.              begin
  1507.                 FDateExt := OldDateExt;
  1508.                 FDayTypeCount := OldCount;
  1509.              end;
  1510.  
  1511.              CalcDaytype(DT, DExt, (AYear = 0), Accepted);
  1512.  
  1513.              FDateExt := DExt;
  1514.  
  1515.              if Accepted then
  1516.              with FDateExt do
  1517.              begin
  1518.                   inc(DayTypeCount);
  1519.                   DaytypeId[DayTypeCount] := DT.Id;
  1520.                   if DT.Holiday then Holiday := true;
  1521.                   if DT.Flagday then Flagday := true;
  1522.                   if DT.ChurchDay then ChurchDay := true;
  1523.              end;
  1524.              inc(AnInd);
  1525.         end;
  1526.         FDaytypeCount := FDateExt.DaytypeCount;
  1527.    end;
  1528.  
  1529. begin
  1530.      OldDateExt := FDateExt;
  1531.      OldCount := FDaytypeCount;
  1532.      D := ReadDay(FDayNumber);
  1533.      with FDateExt do
  1534.      begin
  1535.           Year := FYear;
  1536.           Wd := ConvertWeekday(D.DOWNum);
  1537.           Holiday := (Wd in FWeekHolidays);
  1538.           ChurchDay := false;
  1539.           Flagday := false;
  1540.  
  1541.           DayNumber := D.Daynum;
  1542.  
  1543.           DayOfWeekNumber := GetDOW(D.DOWNum);
  1544.           NameIndex := DOWtoDayNameIndex(DayOfWeekNumber);
  1545.  
  1546.           DayName := Daynames[NameIndex];
  1547.           MonthDay := FMonthDay;
  1548.  
  1549.           MonthNumber := D.Month;
  1550.           WeekNumber := D.Week;
  1551.  
  1552.           FDayTypeCount := 0;
  1553.           FDateExt.DaytypeCount := 0;
  1554.  
  1555.           DayType := D.DayCode;
  1556.  
  1557.           if (DayType in [1..ChurchDayCount])
  1558.           and not FHidePredefineds then
  1559.           with IdList.Objects[Daytype-1] as
  1560.           TDaytype do
  1561.           begin
  1562.                inc(FDayTypeCount);
  1563.                DaytypeId[FDayTypeCount] := DayType;
  1564.                if Holiday then FDateExt.Holiday := true;
  1565.                if Flagday then FDateExt.Flagday := true;
  1566.           end;
  1567.  
  1568.           with DateList do
  1569.           //Check userdefined daytypes
  1570.           begin
  1571.                Key := IntToStr(FMonth * 100 + FMonthDay);
  1572.                if Length(Key) = 3 then Key := '0' + Key;
  1573.                if Find(Key, Ind) then
  1574.                begin
  1575.                     CountFixedDates(Key, Ind)
  1576.                end;
  1577.                Key := '0100';
  1578.                if Find(Key, Ind) then
  1579.                    CountReldays(Ind);
  1580.  
  1581.                if FAllowUserCalc
  1582.                and not FCalcDisabled then
  1583.                begin
  1584.                     Key := '0010';
  1585.                     if Find(Key, Ind) then
  1586.                        CountCalcdays(Ind);
  1587.                end;
  1588.           end;
  1589.  
  1590.           FDateExt.DaytypeCount := FDaytypeCount;
  1591.      end;
  1592. end;
  1593.  
  1594. procedure TKronos.SetYear;
  1595. var
  1596.    Daynum : integer;
  1597.    Day : TDay;
  1598.    Wd : TWeekDay;
  1599.    TrWeekNum, TrMonthDay, TrWeekday : boolean;
  1600.    A, D : word;
  1601. begin
  1602.      if Value = FYear then exit;
  1603.      if Value > FMaxYear then
  1604.      begin
  1605.         if csDesigning in ComponentState then
  1606.            Value := FMaxYear
  1607.         else
  1608.         begin
  1609.            FTransError := FChanging;
  1610.            raise EKronosError.Create(c_YearOutOfBounds);
  1611.         end
  1612.      end;
  1613.      if Value < FMinYear then
  1614.      begin
  1615.         if csDesigning in ComponentState then
  1616.            Value := FMinYear
  1617.         else
  1618.         begin
  1619.            FTransError := FChanging;
  1620.            raise EKronosError.Create(c_YearOutOfBounds);
  1621.         end;
  1622.      end;
  1623.  
  1624.      FYear := Value;
  1625.  
  1626.      TrWeekNum := false;
  1627.      TrMonthDay := false;
  1628.      TrWeekDay := false;
  1629.  
  1630.      if (FMonthDay = 29) and (FMonth = 2) and not IsLeap(FYear) then
  1631.      begin
  1632.           FMonthDay := 28;
  1633.           TrMonthDay := true;
  1634.      end;
  1635.      ChangeKron(FYear);
  1636.      Daynum := ReadDayNr(FMonth * 100 + FMonthDay);
  1637.      if Daynum <> FDayNumber then
  1638.      begin
  1639.           FDayNumber := Daynum;
  1640.      end;
  1641.      Day := ReadDay(Daynum);
  1642.      if Day.Week <> FWeek then
  1643.      begin
  1644.           FWeek := Day.Week;
  1645.           TrWeekNum := true;
  1646.      end;
  1647.      Wd := ConvertWeekday(Day.DOWNum);
  1648.      if Wd <> FWeekday then
  1649.      begin
  1650.           FWeekDay := Wd;
  1651.           TrWeekDay := true;
  1652.      end;
  1653.  
  1654.      SetYearExt;
  1655.      SetMonthExt;
  1656.      SetWeekExt;
  1657.      SetDateExt(0,0,0,0, Cal, DayCodes);
  1658.  
  1659.      ChangeYear;
  1660.      ChangeMonth;
  1661.      ChangeWeek;
  1662.      if TrWeekNum then
  1663.         ChangeWeekNumber;
  1664.      ChangeDate;
  1665.      if TrMonthDay then
  1666.         ChangeMonthDay;
  1667.      if TrWeekDay then
  1668.         ChangeWeekday;
  1669.      if IsToday(A, D) then
  1670.         Today;
  1671. end;
  1672.  
  1673. procedure TKronos.SetMinYear;
  1674. begin
  1675.      if Value < 1 then Value := 1;
  1676.      if Value = FMinYear then exit;
  1677.      if Value > FMaxYear then
  1678.      begin
  1679.         if csDesigning in ComponentState then
  1680.            Value := FMinYear
  1681.         else
  1682.         begin
  1683.            FTransError := FChanging;
  1684.            raise EKronosError.Create(c_MinYearOutOfBounds);
  1685.         end;
  1686.      end;
  1687.      if Value > FYear then
  1688.      begin
  1689.           if csDesigning in ComponentState then
  1690.              Year := Value
  1691.           else
  1692.           begin
  1693.              FTransError := FChanging;
  1694.              raise EKronosError.Create(c_MinYearOutOfCurrentYear);
  1695.           end;
  1696.      end;
  1697.      FMinYear := Value;
  1698. end;
  1699.  
  1700. procedure TKronos.SetMaxYear;
  1701. begin
  1702.      if Value = FMaxYear then exit;
  1703.      if Value > 9999 then Value := 9999;
  1704.      if Value < FMinYear then
  1705.      begin
  1706.         if csDesigning in ComponentState then
  1707.            Value := FMaxYear
  1708.         else
  1709.         begin
  1710.            FTransError := FChanging;
  1711.            raise EKronosError.Create(c_MaxYearOutOfBounds);
  1712.         end;
  1713.      end;
  1714.      if Value < FYear then
  1715.      begin
  1716.           if csDesigning in ComponentState then
  1717.              Year := Value
  1718.           else
  1719.           begin
  1720.              FTransError := FChanging;
  1721.              raise EKronosError.Create(c_MaxYearOutOfCurrentYear);
  1722.           end;
  1723.      end;
  1724.      FMaxYear := Value;
  1725. end;
  1726.  
  1727. procedure TKronos.SetHidePredefineds;
  1728. begin
  1729.      FHidePredefineds := Value;
  1730.      UpdateInfo;
  1731. end;
  1732.  
  1733. procedure TKronos.SetMonth;
  1734. var
  1735.    M : TMonth;
  1736.    D : TDay;
  1737.    Wd : TWeekDay;
  1738.    TrWeek, TrWeekday, TrMonthDay : boolean;
  1739.    A, DNr : word;
  1740. begin
  1741.      if Value = FMonth then exit;
  1742.      if not (Value in [1..12]) then
  1743.      begin
  1744.           if csDesigning in ComponentState then
  1745.           begin
  1746.                if Value < 1 then
  1747.                   Value := 1
  1748.                else
  1749.                   Value := 12;
  1750.           end
  1751.           else
  1752.           begin
  1753.               FTransError := FChanging;
  1754.               raise EKronosError.Create(c_MonthOutOfBounds);
  1755.           end;
  1756.      end;
  1757.  
  1758.      FMonth := Value;
  1759.      M := ReadMonth(FMonth);
  1760.  
  1761.      TrWeek := false;
  1762.      TrWeekday := false;
  1763.      TrMonthDay := false;
  1764.  
  1765.      with M do
  1766.      begin
  1767.           if FMonthDay > Daycount then
  1768.           begin
  1769.              FMonthDay := Daycount;
  1770.              TrMonthDay := true;
  1771.           end;
  1772.           FDayNumber := ReadDayNr(FMonth * 100 + FMonthDay);
  1773.           D := ReadDay(FDayNumber);
  1774.           if FWeek <> D.Week then
  1775.           begin
  1776.                FWeek := D.Week;
  1777.                TrWeek := true;
  1778.           end;
  1779.           Wd := ConvertWeekDay(D.DOWNum);
  1780.           if Wd <> FWeekday then
  1781.           begin
  1782.                TrWeekDay := true;
  1783.                FWeekday := Wd;
  1784.           end;
  1785.      end;
  1786.      SetMonthExt;
  1787.      if TrWeek then
  1788.         SetWeekExt;
  1789.      SetDateExt(0,0,0,0, Cal, DayCodes);
  1790.  
  1791.      ChangeMonth;
  1792.      ChangeMonthNumber;
  1793.      if TrWeek then
  1794.      begin
  1795.         ChangeWeek;
  1796.         ChangeWeekNumber;
  1797.      end;
  1798.      ChangeDate;
  1799.      if TrMonthDay then
  1800.         ChangeMonthDay;
  1801.      if TrWeekday then
  1802.         ChangeWeekDay;
  1803.      if IsToday(A, DNr) then
  1804.         ToDay;
  1805.  
  1806. end;
  1807.  
  1808. procedure TKronos.SetMonthDay;
  1809. var
  1810.    D : TDay;
  1811.    Daynum : word;
  1812.    TrWeek, TrWeekDay : boolean;
  1813.    Wd : TWeekDay;
  1814.    A, Dnr : word;
  1815. begin
  1816.      if Value = FMonthDay then exit;
  1817.      if (Value > MonthExt.NumDays) or (Value < 1) then
  1818.      begin
  1819.           if csDesigning in ComponentState then
  1820.           begin
  1821.                if Value < 1 then
  1822.                   Value := 1
  1823.                else
  1824.                   Value := MonthExt.Numdays;
  1825.           end
  1826.           else
  1827.           begin
  1828.               FTransError := FChanging;
  1829.               raise EKronosError.Create(c_MonthdayOutOfBounds);
  1830.           end;
  1831.      end;
  1832.  
  1833.      FMonthDay := Value;
  1834.  
  1835.      Daynum := ReadDayNr(100 * FMonth + FMonthDay);
  1836.      D := ReadDay(Daynum);
  1837.  
  1838.      TrWeek := false;
  1839.      TrWeekday := false;
  1840.  
  1841.      with D do
  1842.      begin
  1843.           if FWeek <> Week then
  1844.           begin
  1845.              FWeek := Week;
  1846.              TrWeek := true;
  1847.           end;
  1848.           Wd := ConvertWeekday(DOWNum);
  1849.           if Wd <> FWeekday then
  1850.           begin
  1851.                FWeekday := Wd;
  1852.                TrWeekDay := true;
  1853.           end;
  1854.           FDayNumber := Daynum;
  1855.      end;
  1856.      if TrWeek then
  1857.         SetWeekExt;
  1858.      SetDateExt(0,0,0,0, Cal, DayCodes);
  1859.  
  1860.      if TrWeek then
  1861.      begin
  1862.         ChangeWeek;
  1863.         ChangeWeekNumber;
  1864.      end;
  1865.      ChangeDate;
  1866.      ChangeMonthDay;
  1867.      if TrWeekDay then
  1868.         ChangeWeekday;
  1869.      if IsToday(A, DNr) then
  1870.         ToDay;
  1871. end;
  1872.  
  1873. procedure TKronos.SetDayNumber;
  1874. var
  1875.    D : TDay;
  1876.    TrMonth, TrWeek, TrWeekday, TrMonthDay : boolean;
  1877.    Wd : TWeekDay;
  1878.    A, Dnr : word;
  1879. begin
  1880.      if Value = FDayNumber then exit;
  1881.  
  1882.      if (Value > FYearExt.NumDays) or (Value < 1) then
  1883.      begin
  1884.           if csDesigning in ComponentState then
  1885.           begin
  1886.                if Value < 1 then
  1887.                    Value := 1
  1888.                else
  1889.                    Value := FYearExt.NumDays;
  1890.           end
  1891.           else
  1892.           begin
  1893.               FTransError := FChanging;
  1894.               raise EKronosError.Create(c_DaynumberOutOfBounds +
  1895.               ' ' + IntTostr(Value));
  1896.           end;
  1897.      end;
  1898.  
  1899.      FDayNumber := Value;
  1900.      D := ReadDay(FDayNumber);
  1901.  
  1902.      TrMonth := false;
  1903.      TrWeek := false;
  1904.      TrWeekDay := false;
  1905.      TrMonthDay := false;
  1906.  
  1907.      with D do
  1908.      begin
  1909.           if FMonth <> Month then
  1910.           begin
  1911.                FMonth := Month;
  1912.                TrMonth := true;
  1913.           end;
  1914.           if FWeek <> Week then
  1915.           begin
  1916.                FWeek := Week;
  1917.                TrWeek := true;
  1918.           end;
  1919.           Wd := ConvertWeekday(DOWNum);
  1920.           if FWeekday <> Wd then
  1921.           begin
  1922.                FWeekday := Wd;
  1923.                TrWeekDay := true;
  1924.           end;
  1925.           if FMonthday <> (MonthDate mod 100) then
  1926.           begin
  1927.                FMonthDay := MonthDate mod 100;
  1928.                TrMonthDay := true;
  1929.           end;
  1930.      end;
  1931.      if TrMonth then
  1932.         SetMonthExt;
  1933.      if TrWeek then
  1934.         SetWeekExt;
  1935.      SetDateExt(0,0,0,0, Cal, DayCodes);
  1936.  
  1937.      if TrMonth then
  1938.      begin
  1939.         ChangeMonth;
  1940.         ChangeMonthNumber;
  1941.      end;
  1942.      if TrWeek then
  1943.      begin
  1944.         ChangeWeek;
  1945.         ChangeWeekNumber;
  1946.      end;
  1947.      ChangeDate;
  1948.      if TrMonthday then
  1949.          ChangeMonthDay;
  1950.      if TrWeekday then
  1951.         ChangeWeekday;
  1952.      if IsToday(A, Dnr) then
  1953.         Today;
  1954. end;
  1955.  
  1956. procedure TKronos.SetWeekDay;
  1957. var
  1958.    D : TDay;
  1959.    TrMonth, TrWeek, TrYear : boolean;
  1960.    Diff : shortint;
  1961.    NewWd, OldWd : word;
  1962.    Daynum : integer;
  1963.    AntDager : integer;
  1964.    Ud1, Ud2 : word;
  1965.    A, Dnr : word;
  1966. begin
  1967.      if Value = FWeekday then exit;
  1968.      OldWd := ord(FWeekday);
  1969.      NewWd := ord(Value);
  1970.      if OldWd = 0 then OldWd := 7;
  1971.      if NewWd = 0 then NewWd := 7;
  1972.      Ud1 := GetDow(OldWd);
  1973.      Ud2 := GetDow(NewWd);
  1974.  
  1975.      //Sunday = 1, Monday = 2, etc
  1976.  
  1977.      Diff := Ud2 - Ud1;
  1978.  
  1979.      TrMonth := false;
  1980.      TrWeek := false;
  1981.      TrYear := false;
  1982.  
  1983.      if IsLeap(FYear) then
  1984.          AntDager := 366
  1985.      else
  1986.          AntDager := 365;
  1987.  
  1988.      FWeekday := Value;
  1989.  
  1990.      if csLoading in Componentstate then
  1991.         exit;
  1992.  
  1993.      Daynum := FDayNumber + Diff;
  1994.      if Daynum < 1 then
  1995.      begin
  1996.           if FYear - 1 < FMinYear then
  1997.           begin
  1998.              FTransError := FChanging;
  1999.              raise EKronosError.Create(c_YearOutOfBounds);
  2000.           end;
  2001.  
  2002.           if IsLeap(FYear - 1) then
  2003.              Daynum := 366 + Daynum
  2004.           else
  2005.              Daynum := 365 + Daynum;
  2006.           FYear := FYear - 1;
  2007.           FMonth := 12;
  2008.           FDayNumber := Daynum;
  2009.           ChangeKron(FYear);
  2010.           D := ReadDay(FDayNumber);
  2011.           FMonthDay := D.MonthDate mod 100;
  2012.           FWeek := D.Week;
  2013.           TrYear := true;
  2014.           TrWeek := true;
  2015.           TrMonth := true;
  2016.      end
  2017.      else if Daynum > AntDager then
  2018.      begin
  2019.           if FYear + 1 > FMaxYear then
  2020.           begin
  2021.              FTransError := FChanging;
  2022.              raise EKronosError.Create(c_YearOutOfBounds);
  2023.           end;
  2024.  
  2025.           Daynum := Daynum - AntDager;
  2026.           FYear := FYear + 1;
  2027.           FMonth := 1;
  2028.           FDayNumber := Daynum;
  2029.           ChangeKron(FYear);
  2030.           D := ReadDay(FDayNumber);
  2031.           FWeek := D.Week;
  2032.           FMonthDay := D.MonthDate mod 100;
  2033.           TrYear := true;
  2034.           TrWeek := true;
  2035.           TrMonth := true;
  2036.      end
  2037.      else
  2038.      begin
  2039.           FDayNumber := Daynum;
  2040.           D := ReadDay(FDayNumber);
  2041.           if D.Week <> FWeek then
  2042.           begin
  2043.                FWeek := D.Week;
  2044.                TrWeek := true;
  2045.           end;
  2046.           if D.Month <> FMonth then
  2047.           begin
  2048.                FMonth := D.Month;
  2049.                TrMonth := true;
  2050.           end;
  2051.           FMonthDay := D.MonthDate mod 100;
  2052.      end;
  2053.  
  2054.      if TrYear then
  2055.         SetYearExt;
  2056.      if TrMonth then
  2057.         SetMonthExt;
  2058.      if TrWeek then
  2059.         SetWeekExt;
  2060.      SetDateExt(0,0,0,0, Cal, DayCodes);
  2061.  
  2062.      if TrYear then
  2063.         ChangeYear;
  2064.      if TrMonth then
  2065.      begin
  2066.         ChangeMonth;
  2067.         ChangeMonthNumber;
  2068.      end;
  2069.      if TrWeek then
  2070.      begin
  2071.         ChangeWeek;
  2072.         ChangeWeekNumber;
  2073.      end;
  2074.      ChangeDate;
  2075.      ChangeMonthDay;
  2076.      ChangeWeekday;
  2077.      if IsToday(A, Dnr) then
  2078.         Today;
  2079. end;
  2080.  
  2081. procedure TKronos.SetWeek;
  2082. var
  2083.    U : TWeek;
  2084.    D : TDay;
  2085.    TrMonth, TrYear : boolean;
  2086.    Wd, BoundingWd : word;
  2087.    TheYear : TYear;
  2088.    LastWeek : word;
  2089.    A, Dnr : word;
  2090. begin
  2091.      if Value = FWeek then exit;
  2092.      if (Value > FYearExt.NumWeeks) or (Value < 1) then
  2093.      begin
  2094.           if csDesigning in ComponentState then
  2095.           begin
  2096.                if Value < 1 then
  2097.                   Value := 1
  2098.                else
  2099.                   Value := FYearExt.NumWeeks;
  2100.           end
  2101.           else
  2102.           begin
  2103.               FTransError := FChanging;
  2104.               raise EKronosError.Create(c_WeekOutOfBounds);
  2105.           end;
  2106.      end;
  2107.  
  2108.      FWeek := Value;
  2109.  
  2110.      if csLoading in Componentstate then
  2111.      begin
  2112.         SetWeekExt;
  2113.         exit;
  2114.      end;
  2115.  
  2116.      LastWeek := FYearExt.NumWeeks;
  2117.      U := ReadWeek(FWeek);
  2118.  
  2119.      TrMonth := false;
  2120.      TrYear := false;
  2121.  
  2122.      Wd := FDateExt.DayOfWeekNumber;
  2123.      with U do
  2124.      begin
  2125.           if Fweek = 1 then
  2126.             BoundingWd := 7 - (WhichDays[2] - WhichDays[1])
  2127.           else
  2128.             BoundingWd := WhichDays[2] - WhichDays[1] + 1;
  2129.           if (Wd > BoundingWd) and (FWeek = LastWeek) then
  2130.           begin
  2131.                if FYear + 1 > FMaxYear then
  2132.                begin
  2133.                  FTransError := FChanging;
  2134.                  raise EKronosError.Create(c_YearOutOfBounds);
  2135.                end;
  2136.                FYear := FYear + 1;
  2137.                ChangeKron(FYear);
  2138.                FWeek := 1;
  2139.                FMonth := 1;
  2140.                TrMonth := true;
  2141.                TrYear := true;
  2142.                FDayNumber := Wd - BoundingWd;
  2143.           end
  2144.           else if (Wd < BoundingWd) and (FWeek = 1) then
  2145.           //Ukedagen i current date tilh°rer siste Week i forrige σr}
  2146.           begin
  2147.                if FYear - 1 < FMinYear then
  2148.                begin
  2149.                  FTransError := FChanging;
  2150.                  raise EKronosError.Create(c_YearOutOfBounds);
  2151.                end;
  2152.                FYear := FYear - 1;
  2153.                ChangeKron(FYear);
  2154.                TheYear := ReadYear;
  2155.                FWeek := TheYear.WeekCount;
  2156.                FMonth := 12;
  2157.                TrMonth := true;
  2158.                TrYear := true;
  2159.                FDayNumber := TheYear.Daycount - (BoundingWd - Wd) + 1;
  2160.           end
  2161.           else if (Wd >= BoundingWd) and (FWeek = 1) then
  2162.           begin
  2163.                FDayNumber := Wd - BoundingWd + 1;
  2164.           end
  2165.           else if (Wd <= BoundingWd) and (FWeek = LastWeek) then
  2166.           begin
  2167.                FDayNumber := YearExt.NumDays - (BoundingWd - Wd) + 1;
  2168.           end
  2169.           else
  2170.               FDayNumber := WhichDays[1] + Wd - 1;
  2171.           D := ReadDay(FDayNumber);
  2172.           if FMonth <> D.Month then
  2173.           begin
  2174.                FMonth := D.Month;
  2175.                TrMonth := true;
  2176.           end;
  2177.           FMonthDay := D.MonthDate mod 100;
  2178.      end;
  2179.  
  2180.      if TrYear then
  2181.         SetYearExt;
  2182.      if TrMonth then
  2183.         SetMonthExt;
  2184.      SetWeekExt;
  2185.      SetDateExt(0,0,0,0, Cal, DayCodes);
  2186.  
  2187.      if TrYear then
  2188.         ChangeYear;
  2189.      if TrMonth then
  2190.      begin
  2191.         ChangeMonth;
  2192.         ChangeMonthNumber;
  2193.      end;
  2194.      ChangeWeek;
  2195.      ChangeWeekNumber;
  2196.      ChangeDate;
  2197.      ChangeMonthDay;
  2198.      if IsToday(A, Dnr) then
  2199.         Today;
  2200. end;
  2201.  
  2202. procedure TKronos.ChangeYear;
  2203. begin
  2204.      if FEventsDisabled then exit;
  2205.      if FChanging then
  2206.      begin
  2207.           FEventBuf[ocYear] := true;
  2208.           exit;
  2209.      end;
  2210.      if Assigned(FOnChangeYear) then FOnChangeYear(Self);
  2211. end;
  2212.  
  2213. procedure TKronos.ChangeMonth;
  2214. begin
  2215.      if FEventsDisabled then exit;
  2216.      if FChanging then
  2217.      begin
  2218.           FEventBuf[ocMonth] := true;
  2219.           exit;
  2220.      end;
  2221.      if Assigned(FOnChangeMonth) then FOnChangeMonth(Self);
  2222. end;
  2223.  
  2224. procedure TKronos.ChangeMonthNumber;
  2225. begin
  2226.      if FEventsDisabled then exit;
  2227.      if FChanging then
  2228.      begin
  2229.           FEventBuf[ocMonthNumber] := true;
  2230.           exit;
  2231.      end;
  2232.      if Assigned(FOnChangeMonthNumber) then FOnChangeMonthNumber(Self);
  2233. end;
  2234.  
  2235. procedure TKronos.ChangeWeek;
  2236. begin
  2237.      if FEventsDisabled then exit;
  2238.      if FChanging then
  2239.      begin
  2240.           FEventBuf[ocWeek] := true;
  2241.           exit;
  2242.      end;
  2243.      if Assigned(FOnChangeWeek) then FOnChangeWeek(Self);
  2244. end;
  2245.  
  2246. procedure TKronos.ChangeWeekNumber;
  2247. begin
  2248.      if FEventsDisabled then exit;
  2249.      if FChanging then
  2250.      begin
  2251.           FEventBuf[ocWeeknumber] := true;
  2252.           exit;
  2253.      end;
  2254.      if Assigned(FOnChangeWeekNumber) then FOnChangeWeekNumber(Self);
  2255. end;
  2256.  
  2257. procedure TKronos.ChangeMonthday;
  2258. begin
  2259.      if FEventsDisabled then exit;
  2260.      if FChanging then
  2261.      begin
  2262.           FEventBuf[ocMonthday] := true;
  2263.           exit;
  2264.      end;
  2265.      if Assigned(FOnChangeMonthDay) then FOnChangeMonthDay(Self);
  2266. end;
  2267.  
  2268. procedure TKronos.ChangeWeekDay;
  2269. begin
  2270.      if FEventsDisabled then exit;
  2271.      if FChanging then
  2272.      begin
  2273.           FEventBuf[ocWeekDay] := true;
  2274.           exit;
  2275.      end;
  2276.      if Assigned(FOnChangeWeekDay) then FOnChangeWeekDay(Self);
  2277. end;
  2278.  
  2279.  
  2280. procedure TKronos.ChangeDate;
  2281. begin
  2282.      if FEventsDisabled then exit;
  2283.      if FChanging then
  2284.      begin
  2285.           FEventBuf[ocDate] := true;
  2286.           exit;
  2287.      end;
  2288.      if Assigned(FOnChangeDate) then FOnChangeDate(Self);
  2289. end;
  2290.  
  2291. procedure TKronos.Today;
  2292. begin
  2293.      if FEventsDisabled then exit;
  2294.      if FChanging then
  2295.      begin
  2296.           FEventBuf[ocToday] := true;
  2297.           exit;
  2298.      end;
  2299.      if Assigned(FOnToday) then FOnToday(Self);
  2300. end;
  2301.  
  2302. procedure TKronos.CalcDaytype;
  2303. begin
  2304.      Accepted := false;
  2305.      if FCalcDisabled or not FAllowUserCalc then exit;
  2306.      if FChanging then
  2307.      begin
  2308.           FEventBuf[ocCalcDaytype] := true;
  2309.           exit;
  2310.      end;
  2311.      if Assigned(FOnCalcDaytype) then
  2312.      begin
  2313.           try
  2314.              FAllowUserCalc := false;
  2315.              FCalculating := True;
  2316.              {Turn off user calc. Necessary to prevent user from
  2317.              eternalnally triggering the OnCalDaytype event}
  2318.              FOnCalcDaytype(Self, Daytype, ADateExt,
  2319.              IsCurrentDate, Accepted);
  2320.           finally
  2321.              FAllowUserCalc := true;
  2322.              FCalculating := false;
  2323.           end;
  2324.      end;
  2325. end;
  2326.  
  2327. procedure TKronos.LoadDaytype;
  2328. begin
  2329.      LoadIt := true;
  2330.      if Assigned(FOnLoadDaytype) then
  2331.         FOnLoadDaytype(Self,DaytypeDef,LoadIt);
  2332. end;
  2333.  
  2334. procedure TKronos.SaveDaytype;
  2335. begin
  2336.      SaveIt := true;
  2337.      if Assigned(FOnSaveDaytype) then
  2338.         FOnSaveDaytype(Self,Daytype,SaveIt);
  2339. end;
  2340.  
  2341.  
  2342. function TKronos.AddDaytype;
  2343. var
  2344.    Key : string;
  2345.    Ind : integer;
  2346.    i : integer;
  2347. begin
  2348.     Result := NextId;
  2349.     Ind := NameList.Add(AnsiUppercase(Daytype.TheName));
  2350.     Daytype.SetId(NextId);
  2351.  
  2352.     NameList.Objects[Ind] := Daytype;
  2353.     if Daytype.UserCalc then
  2354.          Key := '0010'
  2355.     else if Daytype.TheDate <> 0 then
  2356.     begin
  2357.         Key := IntToStr(Daytype.TheDate);
  2358.         if Length(Key) = 3 then
  2359.            Key := '0' + Key;
  2360.     end
  2361.     else if (Daytype.TheDate = 0) and (Daytype.RelDaytype = 0) then
  2362.         Key := '0000'
  2363.     else
  2364.         Key := '0100';
  2365.  
  2366.     Ind := DateList.Add(Key);
  2367.     DateList.Objects[Ind] := Daytype;
  2368.  
  2369.     Key := IntToStr(NextId);
  2370.     for i := 1 to 6 - Length(Key) do Key := '0' + Key;
  2371.     Ind := IdList.Add(Key);
  2372.     IdList.Objects[Ind] := Daytype;
  2373.     Inc(NextId);
  2374. end;
  2375.  
  2376. procedure TKronos.ClearUserDaytypes;
  2377. begin
  2378.      ClearLists;
  2379.      UpdateInfo;
  2380. end;
  2381.  
  2382. procedure TKronos.DeleteUserdaytype;
  2383. var
  2384.    IdInd : integer;
  2385.    Found : boolean;
  2386.    DT : TDaytype;
  2387.    Id, ADate, Rel : Integer;
  2388.    Key : string;
  2389.    I, Ind : integer;
  2390.    IsCalc : boolean;
  2391.  
  2392. begin
  2393.      DT := GetDaytypeObject(AnId, AName);
  2394.      AName := DT.TheName;
  2395.      AnId := DT.Id;
  2396.  
  2397.      Key := IntToStr(DT.ID);
  2398.      for I := 1 to 6 - Length(Key) do Key := '0' + Key;
  2399.      IdList.Find(Key,IdInd);
  2400.  
  2401.      if IdInd <= FCspIndex then
  2402.      {Predfined daytype. Can't delete}
  2403.         raise EKronosError.Create(c_CannotDeleteStableDaytype + ' ' +
  2404.         DT.TheName);
  2405.  
  2406.      Id := DT.ID;
  2407.      ADate := DT.TheDate;
  2408.      Rel := DT.RelDaytype;
  2409.      IsCalc := DT.UserCalc;
  2410.  
  2411.      if not NameList.Find(AnsiUppercase(Trim(AName)), Ind) then
  2412.        raise EKronosError.Create('Internal error');
  2413.      NameList.Delete(Ind);
  2414.  
  2415.      Key := IntToStr(Id);
  2416.      for i := 1 to 6 - Length(Key) do Key := '0' + Key;
  2417.      if not IdList.Find(Key, Ind) then
  2418.         raise EKronosError.Create('Internal error');
  2419.      IdList.Delete(Ind);
  2420.  
  2421.      if IsCalc then
  2422.          Key := '0010'
  2423.      else if ADate <> 0 then
  2424.      begin
  2425.           Key := IntToStr(ADate);
  2426.           if Length(Key) = 3 then
  2427.              Key := '0' + Key;
  2428.      end
  2429.      else if (ADate = 0) and (Rel = 0) then
  2430.           Key := '0000'
  2431.      else
  2432.           Key := '0100';
  2433.  
  2434.      if not DateList.Find(Key, Ind) then
  2435.         raise EKronosError.Create('Internal error');
  2436.      DT := TDaytype(DateList.Objects[Ind]);
  2437.      Found := (DT.Id = Id);
  2438.      while not Found and (Ind < DateList.Count-1) do
  2439.      begin
  2440.           inc(Ind);
  2441.           DT := TDaytype(DateList.Objects[Ind]);
  2442.           Found := (DT.Id = Id)
  2443.      end;
  2444.      if not Found then
  2445.           raise EKronosError.Create('Internal error');
  2446.      DateList.Objects[ind].Free;
  2447.      DateList.Delete(Ind);
  2448.      UpdateInfo;
  2449. end;
  2450.  
  2451. procedure TKronos.UpdateDaytype;
  2452. var
  2453.    DT : TDaytype;
  2454.    OldKey, NewKey : string;
  2455.    IDKey : string;
  2456.    Ind : integer;
  2457.  
  2458.    function GetKey(ADate, AReldaytype : word; IsCalc : boolean) : string;
  2459.    begin
  2460.         if IsCalc then
  2461.            Result := '0010'
  2462.         else if (ADate = 0) and (ARelDaytype = 0) then
  2463.            Result := '0000'
  2464.         else if ADate = 0 then
  2465.            Result := '0100'
  2466.         else
  2467.            Result := IntToStr(DT.TheDate);
  2468.         if Length(Result) = 3 then
  2469.            Result := '0' + Result;
  2470.     end;
  2471.  
  2472. begin
  2473.      DT := GetDaytypeObject(AnId, AName);
  2474.      OldKey := GetKey(DT.TheDate, DT.Reldaytype, DT.UserCalc);
  2475.  
  2476.      DT.Update(DaytypeDef, FFirstUserId);
  2477.      AnId := DT.Id;
  2478.      AName := DT.TheName;
  2479.  
  2480.      NewKey := GetKey(DT.TheDate, DT.Reldaytype, DT.UserCalc);
  2481.  
  2482.      if not NameList.Find(AnsiUppercase(Trim(AName)), Ind) then
  2483.         raise EKronosError.Create('Internal error');
  2484.  
  2485.      if AnsiUpperCase(DaytypeDef.AName) <> NameList[Ind] then
  2486.      begin
  2487.            NameList.Delete(Ind);
  2488.            Ind := NameList.Add(AnsiUpperCase(DaytypeDef.AName));
  2489.            NameList.Objects[Ind] := DT;
  2490.      end;
  2491.  
  2492.      if (OldKey <> NewKey)
  2493.      and (DT.Id >= FFirstUserId) then
  2494.      begin
  2495.           DateList.Find(OldKey, Ind);
  2496.           DateList.Delete(Ind);
  2497.           Ind := DateList.Add(NewKey);
  2498.           DateList.Objects[Ind] := DT;
  2499.      end;
  2500.  
  2501.      UpdateInfo;
  2502. end;
  2503.  
  2504. function TKronos.GetDaytypeDef;
  2505. var
  2506.    DT : TDaytype;
  2507. begin
  2508.      DT := GetDaytypeObject(AnId, AName);
  2509.      with Result do
  2510.      begin
  2511.           AName := DT.TheName;
  2512.           ADate := DT.TheDate;
  2513.           ARelDayType := DT.Reldaytype;
  2514.           AnOffset := DT.Offset;
  2515.           AFirstShowUp := DT.FirstShowUp;
  2516.           ALastShowUp := DT.LastShowUp;
  2517.           AShowUpFrequency := DT.ShowUpFrequency;
  2518.           AChurchDay := DT.Churchday;
  2519.           AHoliday := DT.Holiday;
  2520.           AFlagday := DT.FlagDay;
  2521.           ATag := DT.Tag;
  2522.      end;
  2523. end;
  2524.  
  2525. function TKronos.GetDayTypeObject;
  2526. var
  2527.    Ind : integer;
  2528.    Sid : string;
  2529.    i : integer;
  2530. begin
  2531.      Result := nil;
  2532.      if AnId <> 0 then
  2533.       begin
  2534.            Sid := IntToStr(AnId);
  2535.            for i := 1 to 6-Length(Sid) do Sid := '0' + Sid;
  2536.            if not IdList.Find(Sid, Ind) then
  2537.               raise EKronosError.Create
  2538.               ('DayType ' + Sid + ' not found');
  2539.            Result := TDaytype(IdList.Objects[Ind]);
  2540.       end
  2541.       else
  2542.       begin
  2543.            if not NameList.Find(AnsiUppercase(Trim(AName)), Ind) then
  2544.               raise EKronosError.Create
  2545.               ('DayType ' + AName + ' not found');
  2546.            Result := TDaytype(NameList.Objects[Ind]);
  2547.       end;
  2548. end;
  2549.  
  2550. function TKronos.GetNextDaytype;
  2551. begin
  2552.      Result := nil;
  2553.      if (NextIndex < 1) or (NextIndex > IdList.Count) then
  2554.          exit;
  2555.      Result := TDaytype(IdList.Objects[NextIndex - 1]);
  2556.      inc(NextIndex);
  2557. end;
  2558.  
  2559.  
  2560. procedure TKronos.SpecifyStandardDay;
  2561. var
  2562.    Def : TDayTypeDef;
  2563. begin
  2564.      Def := GetDaytypeDef(AnId, '');
  2565.      with Def do
  2566.      begin
  2567.           Def.AName := AName;
  2568.           Def.AHoliday := IsHoliday;
  2569.           Def.AFlagday := IsFlagday;
  2570.      end;
  2571.      UpdateDaytype(AnId, '', Def);
  2572. end;
  2573.  
  2574. procedure TKronos.SaveToFile;
  2575. var
  2576.    F : TextFile;
  2577.    i : integer;
  2578.    DT : TDaytype;
  2579.    Accept : boolean;
  2580.    S : string[20];
  2581. begin
  2582.      AssignFile(F, AFilename);
  2583.      Rewrite(F);
  2584.  
  2585.      try
  2586.      Writeln(F,'[Daynames]');
  2587.      Writeln(F,'Sun='+Daynames[1]);
  2588.      Writeln(F,'Mon='+Daynames[2]);
  2589.      Writeln(F,'Tue='+Daynames[3]);
  2590.      Writeln(F,'Wed='+Daynames[4]);
  2591.      Writeln(F,'Thu='+Daynames[5]);
  2592.      Writeln(F,'Fri='+Daynames[6]);
  2593.      Writeln(F,'Sat='+Daynames[7]);
  2594.  
  2595.      Writeln(F);
  2596.      Writeln(F,'[Monthnames]');
  2597.      Writeln(F,'Jan='+Monthnames[1]);
  2598.      Writeln(F,'Feb='+Monthnames[2]);
  2599.      Writeln(F,'Mar='+Monthnames[3]);
  2600.      Writeln(F,'Apr='+Monthnames[4]);
  2601.      Writeln(F,'May='+Monthnames[5]);
  2602.      Writeln(F,'Jun='+Monthnames[6]);
  2603.      Writeln(F,'Jul='+Monthnames[7]);
  2604.      Writeln(F,'Aug='+Monthnames[8]);
  2605.      Writeln(F,'Sep='+Monthnames[9]);
  2606.      Writeln(F,'Oct='+Monthnames[10]);
  2607.      Writeln(F,'Nov='+Monthnames[11]);
  2608.      Writeln(F,'Dec='+Monthnames[12]);
  2609.      Writeln(F);
  2610.  
  2611.      Writeln(F, ';Week');
  2612.      if FFirstWeekDay <> Sunday then
  2613.          Writeln(F,'FirstWeekday='+ IntToStr(Ord(FFirstWeekday)));
  2614.  
  2615.      if FWeekHolidays <> [Sunday,Saturday] then
  2616.      begin
  2617.           Write(F,'WeekHolidays=');
  2618.           if Sunday in FWeekHolidays then
  2619.               Write(F,IntToStr(Ord(Sunday)));
  2620.           if Monday in FWeekHolidays then
  2621.               Write(F,IntToStr(Ord(Monday)));
  2622.           if Tuesday in FWeekHolidays then
  2623.               Write(F,IntToStr(Ord(Tuesday)));
  2624.           if Wednesday in FWeekHolidays then
  2625.               Write(F,IntToStr(Ord(Wednesday)));
  2626.           if Thursday in FWeekHolidays then
  2627.               Write(F,IntToStr(Ord(Thursday)));
  2628.           if Friday in FWeekHolidays then
  2629.               Write(F,IntToStr(Ord(Friday)));
  2630.           if Saturday in FWeekHolidays then
  2631.               Write(F,IntToStr(Ord(Saturday)));
  2632.           Writeln(F);
  2633.      end;
  2634.      Writeln(F);
  2635.  
  2636.      Writeln(F,';Churchdays');
  2637.      for i := 0 to ChurchDayCount - 1 do
  2638.      with IdList.Objects[i]
  2639.      as TDaytype do
  2640.      begin
  2641.           Writeln(F, '[ch' + intToStr(i+1) + ']');
  2642.           Writeln(F, 'Name=' + TheName);
  2643.           if Holiday then
  2644.              Writeln(F, 'Holiday=' + IntToStr(byte(Holiday)));
  2645.           if FlagDay then
  2646.              Writeln(F, 'Flagday=' + IntToStr(byte(Flagday)));
  2647.           Writeln(F);
  2648.      end;
  2649.  
  2650.      Writeln(F,';Commondays');
  2651.      for i := ChurchdayCount to
  2652.      ChurchDayCount + CommondayCount -1 do
  2653.      with IdList.Objects[i] as TDaytype do
  2654.      begin
  2655.           Writeln(F, '[co' + intToStr(i+1) + ']');
  2656.           Writeln(F, 'Name=' + TheName);
  2657.           if Holiday then
  2658.              Writeln(F, 'Holiday=' + IntToStr(byte(Holiday)));
  2659.           if Flagday then
  2660.              Writeln(F, 'Flagday=' + IntToStr(byte(Flagday)));
  2661.           Writeln(F);
  2662.      end;
  2663.  
  2664.      Writeln(F,';Userdefined days');
  2665.  
  2666.      for i := Userdaytype-1 to IdList.Count - 1 do
  2667.      begin
  2668.           DT := TDaytype(IdList.Objects[i]);
  2669.           if i > FCspIndex then
  2670.           begin
  2671.                SaveDaytype(DT,Accept);
  2672.                if not Accept then continue;
  2673.           end;
  2674.  
  2675.           with DT do
  2676.           begin
  2677.                if i <= FCspIndex then
  2678.                   Writeln(F, '[cs' + intToStr(i+1) + ']')
  2679.                else
  2680.                   Writeln(F, '[ud' + intToStr(i+1) + ']');
  2681.                if TheName <> '' then
  2682.                   Writeln(F, 'Name=' + TheName);
  2683.                if TheDate <> 0 then
  2684.                   Writeln(F, 'Date=' + IntToStr(TheDate));
  2685.                if Reldaytype <> 0 then
  2686.                   Writeln(F, 'RelDayType=' + IntToStr(RelDayType));
  2687.                if Offset <> 0 then
  2688.                   Writeln(F, 'Offset=' + IntToStr(Offset));
  2689.                if FirstShowUp <> 1 then
  2690.                   Writeln(F, 'FirstShow=' + IntToStr(FirstShowup));
  2691.                if LastShowUp <> 9999 then
  2692.                   Writeln(F, 'LastShow=' + IntToStr(LastShowup));
  2693.                if ShowUpFrequency <> 1 then
  2694.                   Writeln(F, 'ShowUpFreq=' + IntToStr(ShowUpFrequency));
  2695.                if Churchday then
  2696.                   Writeln(F, 'Churchday=' + IntToStr(byte(Churchday)));
  2697.                if Holiday then
  2698.                   Writeln(F, 'Holiday=' + IntToStr(byte(Holiday)));
  2699.                if Flagday then
  2700.                   Writeln(F, 'Flagday=' + IntToStr(byte(Flagday)));
  2701.                if UserCalc then
  2702.                   Writeln(F, 'Calc=' + IntToStr(byte(UserCalc)));
  2703.                if Tag <> 0 then
  2704.                   Writeln(F, 'Tag=' + IntToStr(Tag));
  2705.                Writeln(F);
  2706.           end;
  2707.      end;
  2708.      finally
  2709.         CloseFile(F);
  2710.      end;
  2711.  
  2712. end;
  2713.  
  2714. procedure TKronos.LoadFromFile;
  2715. var
  2716.    F : TextFile;
  2717.    i : integer;
  2718.    L : string;
  2719.    Stopp : boolean;
  2720.    SectionType : string;
  2721.    SectionNumber : word;
  2722.    SectionSpec : string;
  2723.  
  2724.    procedure GetValues(S : string; var K, V : string);
  2725.    var
  2726.       Ind : integer;
  2727.    begin
  2728.         S := Trim(S);
  2729.         K := '';
  2730.         V := '';
  2731.         if (S = '') or (Pos(';',S) = 1) then
  2732.              exit;
  2733.  
  2734.         if (Pos('[',S) = 1) and (Pos(']',S) = length(S)) then
  2735.         begin
  2736.              K := '%NEXT';
  2737.              exit;
  2738.         end;
  2739.  
  2740.         Ind := Pos('=',S);
  2741.         if (Ind in [1,0]) or (Ind = Length(S)) then
  2742.              exit;
  2743.  
  2744.         K := Trim(AnsiUpperCase(copy(S,1,Ind -1)));
  2745.         V := Trim(copy(S, Ind + 1, length(S) - ind));
  2746.    end;
  2747.  
  2748.    procedure GetSectionSpec(S : string; var SType : string;
  2749.    {Retrieves the alfacode and the index number of a section.
  2750.    Ex: ch5 = CH and 5}
  2751.    var Number : word);
  2752.    var
  2753.       i : integer;
  2754.       SNumber : string;
  2755.    begin
  2756.         Stype := '';
  2757.         SNumber := '';
  2758.         Number := 0;
  2759.         S := AnsiUpperCase(S);
  2760.         for i := 1 to length(S) do
  2761.         begin
  2762.              if S[i] in['A'..'Z'] then
  2763.                SType := SType + S[I]
  2764.              else if S[i] in['0'..'9'] then
  2765.                SNumber := SNumber + S[I];
  2766.  
  2767.         end;
  2768.         if SNumber <> '' then
  2769.            Number := StrToInt(SNumber);
  2770.    end;
  2771.  
  2772.    function DefineDaynames : string;
  2773.    //Returns next section
  2774.    var
  2775.       S : string;
  2776.       Key, Value : string;
  2777.    begin
  2778.         Result := '';
  2779.         repeat
  2780.           if Eof(F) then
  2781.           begin
  2782.                Result := '';
  2783.                break;
  2784.           end;
  2785.           ReadLn(F, S);
  2786.           GetValues(S, Key, Value);
  2787.           if Key = '' then
  2788.             continue
  2789.           else if Key = '%NEXT' then
  2790.           begin
  2791.                Result := S;
  2792.                break;
  2793.           end;
  2794.           if Key = 'SUN' then
  2795.              Daynames[1] := Value
  2796.           else if Key = 'MON' then
  2797.              Daynames[2] := Value
  2798.           else if Key = 'TUE' then
  2799.              Daynames[3] := Value
  2800.           else if Key = 'WED' then
  2801.              Daynames[4] := Value
  2802.           else if Key = 'THU' then
  2803.              Daynames[5] := Value
  2804.           else if Key = 'FRI' then
  2805.              Daynames[6] := Value
  2806.           else if Key = 'SAT' then
  2807.              Daynames[7] := Value
  2808.         until false;
  2809.    end;
  2810.  
  2811.    function DefineMonthnames : string;
  2812.    //Returns next section
  2813.    var
  2814.       S : string;
  2815.       Key, Value : string;
  2816.    begin
  2817.         Result := '';
  2818.         repeat
  2819.           if Eof(F) then
  2820.           begin
  2821.                Result := '';
  2822.                break;
  2823.           end;
  2824.           ReadLn(F, S);
  2825.           GetValues(S, Key, Value);
  2826.           if Key = '' then
  2827.             continue
  2828.           else if Key = '%NEXT' then
  2829.           begin
  2830.                Result := S;
  2831.                break;
  2832.           end;
  2833.           if Key = 'JAN' then
  2834.              Monthnames[1] := Value
  2835.           else if Key = 'FEB' then
  2836.              Monthnames[2] := Value
  2837.           else if Key = 'MAR' then
  2838.              Monthnames[3] := Value
  2839.           else if Key = 'APR' then
  2840.              Monthnames[4] := Value
  2841.           else if Key = 'MAY' then
  2842.              Monthnames[5] := Value
  2843.           else if Key = 'JUN' then
  2844.              Monthnames[6] := Value
  2845.           else if Key = 'JUL' then
  2846.              Monthnames[7] := Value
  2847.           else if Key = 'AUG' then
  2848.              Monthnames[8] := Value
  2849.           else if Key = 'SEP' then
  2850.              Monthnames[9] := Value
  2851.           else if Key = 'OCT' then
  2852.              Monthnames[10] := Value
  2853.           else if Key = 'NOV' then
  2854.              Monthnames[11] := Value
  2855.           else if Key = 'DEC' then
  2856.              Monthnames[12] := Value;
  2857.         until false;
  2858.    end;
  2859.  
  2860.    function DefineWeek : string;
  2861.    //Returns next section
  2862.    var
  2863.       S : string;
  2864.       Key, Value : string;
  2865.       i : integer;
  2866.       n : byte;
  2867.  
  2868.    begin
  2869.         Result := '';
  2870.         FWeekHolidays := [Sunday,Saturday];
  2871.         FFirstWeekday := Sunday;
  2872.         repeat
  2873.           if Eof(F) then
  2874.           begin
  2875.                Result := '';
  2876.                break;
  2877.           end;
  2878.           ReadLn(F, S);
  2879.           GetValues(S, Key, Value);
  2880.           if Key = '' then
  2881.             continue
  2882.           else if Key = '%NEXT' then
  2883.           begin
  2884.                Result := S;
  2885.                break;
  2886.           end;
  2887.           if Key = 'WEEKHOLIDAYS' then
  2888.           begin
  2889.                Value := Trim(Value);
  2890.                FWeekHolidays := [];
  2891.                for i := 1 to length(Value) do
  2892.                begin
  2893.                     if Value[I] in ['0'..'6'] then
  2894.                     begin
  2895.                         n := StrToInt(Value[i]);
  2896.                         FWeekHolidays := FWeekHolidays + [TWeekDay(n)];
  2897.                     end;
  2898.                end;
  2899.           end
  2900.           else if Key = 'FIRSTWEEKDAY' then
  2901.           begin
  2902.                Value := Trim(Value);
  2903.                if length(Value) = 1 then
  2904.                   if Value[1] in ['0'..'6'] then
  2905.                       FFirstWeekDay := TWeekDay(StrToInt(Value[1]));
  2906.           end;
  2907.         until false;
  2908.    end;
  2909.  
  2910.    function DefineStd(Number : word) : string;
  2911.    //Returns next section
  2912.    var
  2913.       S : string;
  2914.       Key, Value : string;
  2915.       AName : string;
  2916.       Flagd, Holid : boolean;
  2917.  
  2918.    begin
  2919.         Result := '';
  2920.         with IdList.Objects[Number-1] as TDaytype do
  2921.         begin
  2922.              Flagd := FlagDay;
  2923.              Holid := Holiday;
  2924.              AName := TheName;
  2925.         end;
  2926.         repeat
  2927.           if Eof(F) then
  2928.           begin
  2929.                Result := '';
  2930.                break;
  2931.           end;
  2932.           ReadLn(F, S);
  2933.           GetValues(S, Key, Value);
  2934.           if Key = '' then
  2935.             continue
  2936.           else if Key = '%NEXT' then
  2937.           begin
  2938.                Result := S;
  2939.                break;
  2940.           end;
  2941.           if Key = 'NAME' then
  2942.           begin
  2943.              AName := Value
  2944.           end
  2945.           else if Key = 'HOLIDAY' then
  2946.              Holid := boolean(strToInt(Value))
  2947.           else if Key = 'FLAGDAY' then
  2948.              FlagD := boolean(strToInt(Value));
  2949.         until false;
  2950.         SpecifyStandardDay(Number, AName, Holid, Flagd);
  2951.    end;
  2952.  
  2953.    function DefineUd(Number : word; SecType : string) : string;
  2954.    //Returns next section
  2955.    var
  2956.       S : string;
  2957.       Key, Value : string;
  2958.       Def : TDaytypeDef;
  2959.       i : integer;
  2960.       SId : string;
  2961.       DT : TDaytype;
  2962.       Upd : boolean;
  2963.       Ind : integer;
  2964.       Accept : boolean;
  2965.  
  2966.    begin
  2967.         Result := '';
  2968.         with Def do
  2969.         begin
  2970.          AName := '';
  2971.          ADate := 0;
  2972.          ARelDayType := 0;
  2973.          AnOffset := 0;
  2974.          AFirstShowUp := 1;
  2975.          ALastShowUp := 9999;
  2976.          AShowupFrequency := 1;
  2977.          ATag := 0;
  2978.          AChurchday := false;
  2979.          AHoliday := false;
  2980.          AFlagDay := false;
  2981.          AUserCalc := false;
  2982.          Upd := false;
  2983.  
  2984.          if (Number <= FFirstUserId)
  2985.          and LoadAll
  2986.          and (SecType = 'CS') then
  2987.          // Updating exisiting country spesific
  2988.          begin
  2989.               Upd := true;
  2990.               SId := IntToStr(Number);
  2991.               for i := 1 to 6 - Length(Sid) do Sid := '0' + Sid;
  2992.               if not IdList.Find(Sid, Ind) then
  2993.                  raise EKronosError.Create('Internal error');
  2994.               DT :=  TDaytype(IdList.Objects[Ind]);
  2995.          end;
  2996.  
  2997.          repeat
  2998.           if Eof(F) then
  2999.           begin
  3000.                Result := '';
  3001.                break;
  3002.           end;
  3003.           ReadLn(F, S);
  3004.           GetValues(S, Key, Value);
  3005.           if Key = '' then
  3006.             continue
  3007.           else if Key = '%NEXT' then
  3008.           begin
  3009.                Result := S;
  3010.                break;
  3011.           end;
  3012.  
  3013.           if Key = 'NAME' then
  3014.           begin
  3015.              AName := Value;
  3016.              if Upd then
  3017.              begin
  3018.                   if AnsiUpperCase(Trim(Value)) <>
  3019.                   AnsiUpperCase(DT.TheName) then
  3020.                   begin
  3021.                        NameList.Delete(Ind);
  3022.                        Ind := NameList.Add(AnsiUpperCase(Value));
  3023.                        NameList.Objects[Ind] := DT;
  3024.                   end;
  3025.              end;
  3026.           end
  3027.           else if Key = 'HOLIDAY' then
  3028.           begin
  3029.              AHoliday := boolean(strToInt(Value));
  3030.           end
  3031.           else if Key = 'FLAGDAY' then
  3032.           begin
  3033.              AFlagDay := boolean(strToInt(Value));
  3034.           end
  3035.           else if Key = 'CHURCHDAY' then
  3036.           begin
  3037.              AChurchDay := boolean(strToInt(Value));
  3038.           end
  3039.           else if Key = 'DATE' then
  3040.           begin
  3041.              if not Upd then ADate := StrToInt(Value);
  3042.           end
  3043.           else if Key = 'RELDAYTYPE' then
  3044.           begin
  3045.              if not Upd then AReldayType := StrToInt(Value);
  3046.           end
  3047.           else if Key = 'OFFSET' then
  3048.           begin
  3049.              if not Upd then AnOffset := StrToInt(Value);
  3050.           end
  3051.           else if Key = 'FIRSTSHOW' then
  3052.           begin
  3053.              if not Upd then AFirstShowUp := StrToInt(Value);
  3054.           end
  3055.           else if Key = 'LASTSHOW' then
  3056.           begin
  3057.              if not Upd then ALastShowUp := StrToInt(Value);
  3058.           end
  3059.           else if Key = 'SHOWUPFREQ' then
  3060.           begin
  3061.              if not Upd then AShowupFrequency := StrToInt(Value);
  3062.           end
  3063.           else if Key = 'TAG' then
  3064.           begin
  3065.              ATag := StrToInt(Value);
  3066.           end
  3067.           else if Key = 'CALC' then
  3068.           begin
  3069.               if not Upd then AUserCalc := boolean(strToInt(Value));
  3070.           end;
  3071.          until false;
  3072.         end;
  3073.  
  3074.         if Sectype = 'UD' then
  3075.         begin
  3076.            LoadDaytype(Def, Accept);
  3077.            if Accept then
  3078.               AddDaytype(TDaytype.Create(Def))
  3079.         end
  3080.         else
  3081.            UpdateDaytype(Number,'',Def);
  3082.    end;
  3083.  
  3084. begin
  3085.      AssignFile(F, AFilename);
  3086.      Reset(F);
  3087.      Stopp := false;
  3088.  
  3089.      ClearLists;
  3090.      try
  3091.         while not Stopp and not Eof(F) do
  3092.         begin
  3093.              ReadLn(F, L);
  3094.              L := Trim(L);
  3095.              Stopp := (Pos('[',L) = 1) and (Pos(']',L) = length(L));
  3096.         end;
  3097.         if not Stopp then exit;
  3098.  
  3099.         GetSectionSpec(L,SectionType, SectionNumber);
  3100.         SectionSpec := L;
  3101.         DisableIndexing(True);
  3102.         try
  3103.         repeat
  3104.               if SectionType = 'CH' then
  3105.               begin
  3106.                  if not (SectionNumber in [1..ChurchdayCount]) then
  3107.                     raise EKronosError.Create('Invalid section (' +
  3108.                    SectionSpec + ') in inputfile');
  3109.                  SectionSpec := DefineStd(SectionNumber);
  3110.               end
  3111.               else if SectionType = 'CO' then
  3112.               begin
  3113.                  if not (SectionNumber in [ChurchdayCount +
  3114.                  1..UserDayType-1]) then
  3115.                     raise EKronosError.Create('Invalid section (' +
  3116.                    SectionSpec + ') in inputfile');
  3117.                  SectionSpec := DefineStd(SectionNumber);
  3118.               end
  3119.               else if (SectionType = 'CS') then
  3120.               begin
  3121.                    if not ((SectionNumber >= Userdaytype)
  3122.                    and (SectionNumber < FFirstUserId)) then
  3123.                     raise EKronosError.Create('Invalid section (' +
  3124.                    SectionSpec + ') in inputfile');
  3125.                    SectionSpec := DefineUd(SectionNumber, SectionType);
  3126.               end
  3127.               else if SectionType = 'UD' then
  3128.                  SectionSpec := DefineUd(SectionNumber, SectionType)
  3129.               else if SectionType = 'DAYNAMES' then
  3130.                  SectionSpec := DefineDaynames
  3131.               else if SectionType = 'MONTHNAMES' then
  3132.                  SectionSpec := DefineMonthnames
  3133.               else if SectionType = 'WEEK' then
  3134.                  SectionSpec := DefineWeek
  3135.               else
  3136.               begin
  3137.                    raise EKronosError.Create('Invalid section (' +
  3138.                    SectionSpec + ') in inputfile');
  3139.               end;
  3140.  
  3141.               if SectionSpec <> '' then
  3142.                  GetSectionSpec(SectionSpec, SectionType, SectionNumber);
  3143.         until SectionSpec = '';
  3144.         finally
  3145.             DisableIndexing(False);
  3146.         end;
  3147.      finally
  3148.         closeFile(F);
  3149.      end;
  3150.      UpdateInfo;
  3151. end;
  3152.  
  3153. procedure TKronos.SetFirstWeekDay;
  3154. begin
  3155.      if FFirstWeekDay = Value then exit;
  3156.      FFirstWeekDay := Value;
  3157.  
  3158.      IntFirstWeekday := Ord(FFirstWeekday);
  3159.      if IntFirstWeekday = 0 then IntFirstWeekday := 7;
  3160.  
  3161.      UpdateInfo;
  3162.      if DateExt.Weeknumber <> FWeek then
  3163.      begin
  3164.           Fweek := DateExt.WeekNumber;
  3165.           SetWeekExt;
  3166.           ChangeWeek;
  3167.           ChangeWeekNumber;
  3168.      end;
  3169. end;
  3170.  
  3171. procedure TKronos.SetWeekHoliDays;
  3172. begin
  3173.      FWeekHolidays := Value;
  3174.      UpdateInfo;
  3175. end;
  3176.  
  3177. procedure TKronos.UpdateInfo;
  3178. {Updates YearExt, DateExt and MonthExt after calls to
  3179. AddDaytype, SpecifyCommonday, SpecifiyChurchDay}
  3180. begin
  3181.      if FYear <> 0 then SetYearExt;
  3182.      if FMonth <> 0 then SetMonthExt;
  3183.      if FDaynumber <> 0 then SetDateExt(0,0,0,0, Cal, DayCodes);
  3184. end;
  3185.  
  3186. procedure TKronos.SetCountrySpecifics;
  3187. begin
  3188.      {Nothing. Use to derive a new component from TKronos}
  3189. end;
  3190.  
  3191. procedure TKronos.SetDefaults;
  3192. var
  3193.    i : integer;
  3194.    Def : TDaytypeDef;
  3195.    TheDaytype : TDaytype;
  3196. {Sets Defaults. Necessary to protect standard daytypes
  3197. from remaining undefined}
  3198. begin
  3199.  
  3200.    // Country spesifications for churchdays and commondays
  3201.    with Def do
  3202.    begin
  3203.      AName :='1. Advent Sunday';
  3204.      ADate := 0;
  3205.      ARelDayType := 0;
  3206.      AnOffset := 0;
  3207.      AFirstShowUp := 1;
  3208.      ALastShowUp := 9999;
  3209.      AShowUpFrequency := 1;
  3210.      AChurchDay := true;
  3211.      AHoliday := false;
  3212.      AFlagday := false;
  3213.      AUserCalc := false;
  3214.      ATag := 0;
  3215.      AddDaytype(TDayType.Create(Def));
  3216.      AName :='2. Advent Sunday';
  3217.      AddDaytype(TDayType.Create(Def));
  3218.      AName :='3. Advent Sunday';
  3219.      AddDaytype(TDayType.Create(Def));
  3220.      AName :='4. Advent Sunday';
  3221.      AddDaytype(TDayType.Create(Def));
  3222.      AName :='Christmas Eve';
  3223.      AddDaytype(TDayType.Create(Def));
  3224.      AName :='Christmas Day';
  3225.      AddDaytype(TDayType.Create(Def));
  3226.      AName :='Boxing Day';
  3227.      AddDaytype(TDayType.Create(Def));
  3228.      AName :='New Year' + '''' + 's Eve';
  3229.      AddDaytype(TDayType.Create(Def));
  3230.      AName :='New Year' + '''' + 's Day';
  3231.      AddDaytype(TDayType.Create(Def));
  3232.      AName :='Shrove Tuesday';
  3233.      AddDaytype(TDayType.Create(Def));
  3234.      AName :='Ash Wednesday';
  3235.      AddDaytype(TDayType.Create(Def));
  3236.      AName :='Palm Sunday';
  3237.      AddDaytype(TDayType.Create(Def));
  3238.      AName :='Maundy Thursday';
  3239.      AddDaytype(TDayType.Create(Def));
  3240.      AName :='Good Friday';
  3241.      AddDaytype(TDayType.Create(Def));
  3242.      AName :='EasterEve';
  3243.      AddDaytype(TDayType.Create(Def));
  3244.      AName :='Easter Sunday';
  3245.      AddDaytype(TDayType.Create(Def));
  3246.      AName :='Easter Monday';
  3247.      AddDaytype(TDayType.Create(Def));
  3248.      AName :='Whit Eve';
  3249.      AddDaytype(TDayType.Create(Def));
  3250.      AName :='Whit Sunday';
  3251.      AddDaytype(TDayType.Create(Def));
  3252.      AName :='Whit Monday';
  3253.      AddDaytype(TDayType.Create(Def));
  3254.      AName :='Ascension Day';
  3255.      AddDaytype(TDayType.Create(Def));
  3256.  
  3257.      AName := 'United Nations Day';
  3258.      ADate := 1023;
  3259.      AFirstShowUp := 1945;
  3260.      AddDaytype(TDayType.Create(Def));
  3261.      AName := 'International Womens Day';
  3262.      ADate := 308;
  3263.      AFirstShowUp := 1910;
  3264.      AddDaytype(TDayType.Create(Def));
  3265.      AName := 'May Day';
  3266.      ADate := 501;
  3267.      AFirstShowUp := 1900;
  3268.      AChurchday := false;
  3269.      AddDaytype(TDayType.Create(Def));
  3270.      AName := 'International Literacy Day';
  3271.      ADate := 908;
  3272.      AFirstShowUp := 1962;
  3273.      AddDaytype(TDayType.Create(Def));
  3274.    end;
  3275.  
  3276.    //Daynames
  3277.    for i := 1 to 7 do
  3278.        Daynames[i] := LongDaynames[i];
  3279.    for i := 1 to 12 do
  3280.        Monthnames[i] := LongMonthnames[i];
  3281. end;
  3282.  
  3283. function TKronos.GetDaytype;
  3284. var
  3285.    DT : TDaytype;
  3286.    ADayTypeId : word;
  3287.    I : integer;
  3288.    Sid : string;
  3289. begin
  3290.      if (AnIndex > FDaytypeCount) or (AnIndex < 0) then
  3291.         raise EKronosError.Create(c_DayTypeIndexOutOfRange);
  3292.  
  3293.      ADayTypeId := FDateExt.DaytypeId[AnIndex];
  3294.      with IdList do
  3295.      begin
  3296.           Sid := IntToStr(ADaytypeId);
  3297.           for i := 1 to 6 - Length(Sid) do Sid := '0' + Sid;
  3298.           if not Find(Sid, i) then
  3299.              raise EKronosError.Create('Internal error');
  3300.           Result := TDaytype(Objects[i]);
  3301.      end;
  3302. end;
  3303.  
  3304. function TKronos.GetMonthImage;
  3305. // Creates then MonthImage
  3306. var
  3307.    I,J : integer;
  3308.    DayCnt, Daynum : word;
  3309.    MndImage : TMonthImage;
  3310.    Day : TDay;
  3311.    UdIndeks : word;
  3312.    WeekNum : word;
  3313.    MonthDate : word;
  3314.    M : TMonth;
  3315.    A : TYear;
  3316. begin
  3317.     I := 1;
  3318.     Daynum := FMonthExt.Firstday;
  3319.     DayCnt := FYearExt.NumDays;
  3320.  
  3321.     FillChar(MndImage,SizeOf(MndImage), 0);
  3322.  
  3323.     while (Cal[Daynum] <= ((Month * 100) + 31))
  3324.     and not (Daynum > DayCnt) do
  3325.     begin
  3326.          Day := ReadDay(Daynum);
  3327.          WeekNum := Day.Week;
  3328.          UdIndeks := GetDOW(Day.DOWNum);
  3329.          MndImage[I, UdIndeks] := Daynum;
  3330.          MndImage[I, 0] := WeekNum;
  3331.          if UdIndeks = 7 then inc(I);
  3332.          inc(Daynum);
  3333.     end;
  3334.  
  3335.     //Fill holes with dates from previous and next month
  3336.     I := 1;
  3337.     while MndImage[1, I] = 0 do
  3338.       inc(I);
  3339.     dec(I);
  3340.     if FMonth = 1 then
  3341.        MonthDate := 31
  3342.     else
  3343.     begin
  3344.          M := ReadMonth(FMonth-1);
  3345.          MonthDate := M.Daycount;
  3346.     end;
  3347.     for J := I downto 1 do
  3348.     begin
  3349.            MndImage[1, J] := -MonthDate;
  3350.            dec(MonthDate);
  3351.     end;
  3352.  
  3353.     I := 1;
  3354.     while MndImage[FMonthExt.NumWeeks, I] <> 0 do
  3355.       inc(I);
  3356.     MonthDate := 1;
  3357.     for J := I to 7 do
  3358.     begin
  3359.          MndImage[FMonthExt.NumWeeks, J] := -MonthDate;
  3360.          inc(MonthDate);
  3361.     end;
  3362.  
  3363.     // Fill weeks that belongs to next month
  3364.     for I := FMonthExt.NumWeeks + 1 to 6 do
  3365.     begin
  3366.          for J := 1 to 7 do
  3367.          begin
  3368.               MndImage[I, J] := -MonthDate;
  3369.               inc(MonthDate);
  3370.          end;
  3371.          if WeekNum = FYearExt.NumWeeks then
  3372.             WeekNum := 1
  3373.          else
  3374.             WeekNum := WeekNum + 1;
  3375.          MndImage[I, 0] := -WeekNum;
  3376.     end;
  3377.     Result := MndImage;
  3378. end;
  3379.  
  3380. procedure TKronos.DisableIndexing;
  3381. begin
  3382.      NameList.Sorted := not Disable;
  3383.      IdList.Sorted := not Disable;
  3384.      DateList.Sorted := not Disable;
  3385. end;
  3386.  
  3387. procedure TKronos.ClearLists;
  3388. var
  3389.    I : integer;
  3390. begin
  3391.      for i := 0 to DateList.Count - 1 do
  3392.          DateList.Objects[I].Free;
  3393.      DateList.Clear;
  3394.      Namelist.Clear;
  3395.      IdList.Clear;
  3396.      NextId := 1;
  3397.      SetDefaults;
  3398.      SetCountrySpecifics;
  3399. end;
  3400.  
  3401.  
  3402. procedure TKronos.DisableEvents;
  3403. begin
  3404.      FEventsDisabled := Disable;
  3405. end;
  3406.  
  3407. procedure TKronos.DisableUserCalc;
  3408. begin
  3409.      FCalcDisabled := Disable;
  3410.      if not Disable and FAllowUserCalc then
  3411.         SetDateExt(0,0,0,0, Cal, DayCodes);
  3412.      {When reenabling Daytype processing it is necessary to recalculate
  3413.      the current DateExt when UserCalc is active.}
  3414. end;
  3415.  
  3416.  
  3417. procedure TKronos.BeginChange;
  3418. begin
  3419.      if FChanging or FEndChange or FEventsDisabled then exit;
  3420.  
  3421.      FTransYear := FYear;
  3422.      FTransDayNr := FDayNumber;
  3423.      FTransError := false;
  3424.      FillChar(FEventBuf,SizeOf(FEventBuf),false);
  3425.      FChanging := true;
  3426. end;
  3427.  
  3428. procedure TKronos.EndChange;
  3429. var
  3430.    e : TOcEvent;
  3431.    de, dt : boolean;
  3432. begin
  3433.      if not FChanging or FEndChange or FEventsDisabled then exit;
  3434.      FChanging := false;
  3435.      if FTransError then
  3436.      begin
  3437.           de := FEventsDisabled;
  3438.           Dt := FCalcDisabled;
  3439.           DisableEvents(true);
  3440.           DisableUserCalc(true);
  3441.           Year := FTransYear;
  3442.           Daynumber := FTransDayNr;
  3443.           DisableEvents(de);
  3444.           DisableUserCalc(dt);
  3445.           FTransError := false;
  3446.           exit;
  3447.      end;
  3448.      FEndChange := true;
  3449.      try
  3450.      for e := ocYear to ocCalcDaytype do
  3451.      begin
  3452.           if FEventBuf[e] then
  3453.           case e of
  3454.           ocYear : ChangeYear;
  3455.           ocMonth : ChangeMonth;
  3456.           ocMonthnumber : ChangeMonthnumber;
  3457.           ocWeek : ChangeWeek;
  3458.           ocWeeknumber : ChangeWeekNumber;
  3459.           ocMonthDay : ChangeMonthDay;
  3460.           ocWeekday : ChangeWeekday;
  3461.           ocDate : ChangeDate;
  3462.           ocToday : Today;
  3463.           ocCalcDaytype : SetDateExt(0,0,0,0, Cal, DayCodes);
  3464.           end;
  3465.      end;
  3466.      finally
  3467.          FEndChange := false;
  3468.      end;
  3469. end;
  3470.  
  3471. function TKronos.IsToday;
  3472. var
  3473.    A, M, D, Wd : word;
  3474.    T1, T2 : TDateTime;
  3475. begin
  3476.      GetDate(A, M, D, Wd);
  3477.      Result :=
  3478.      (FYear = A)
  3479.      and (FMonth = M)
  3480.      and (FMonthDay = D);
  3481.      AYear := A;
  3482.      T1 := EncodeDate(A,1,1);
  3483.      T2 := EncodeDate(A,M,D);
  3484.      ADaynumber := Trunc(T2) - Trunc(T1) + 1;
  3485. end;
  3486.  
  3487. function TKronos.IsTomorrow;
  3488. var
  3489.    A, M, D : word;
  3490.    T1, T2 : TDatetime;
  3491. begin
  3492.      T2 := Date + 1;
  3493.      DecodeDate(T2, A, M, D);
  3494.      T1 := EncodeDate(A,1,1);
  3495.      Result := (FYear = A)
  3496.      and (FMonth = M )
  3497.      and (FMonthDay = D);
  3498.      AYear := A;
  3499.      ADayNumber := Trunc(T2)-Trunc(T1) + 1;
  3500. end;
  3501.  
  3502. function TKronos.IsYesterday;
  3503. var
  3504.    A, M, D : word;
  3505.    T1, T2 : TDatetime;
  3506. begin
  3507.      T2 := Date - 1;
  3508.      DecodeDate(T2, A, M, D);
  3509.      T1 := EncodeDate(A,1,1);
  3510.      Result := (FYear = A)
  3511.      and (FMonth = M )
  3512.      and (FMonthDay = D);
  3513.      AYear := A;
  3514.      ADayNumber := Trunc(T2)-Trunc(T1) + 1;
  3515. end;
  3516.  
  3517. function TKronos.IsThisWeek;
  3518. var
  3519.    A, M, D, Wd : word;
  3520.    T : TDatetime;
  3521.    DExt : TDateExt;
  3522. begin
  3523.      T := Date;
  3524.      DecodeDate(T, A, M, D);
  3525.      DExt := FetchDateExt(A, M, D);
  3526.      Result := (FYear = A)
  3527.      and (FWeek = DExt.WeekNumber);
  3528.      AYear := A;
  3529.      AWeeknumber := DExt.WeekNumber;
  3530. end;
  3531.  
  3532. function TKronos.IsNextWeek;
  3533. var
  3534.    Y, Dnr : Word;
  3535.    YExt : TYearExt;
  3536.    DExt : TDateExt;
  3537.    WExt : TWeekExt;
  3538.    TestWeek, TestYear : word;
  3539.    Dt : boolean;
  3540. begin
  3541.      IsToday(Y, Dnr);
  3542.      Dt := FCalcDisabled;
  3543.      DisableUserCalc(True);
  3544.      try
  3545.         DExt := FetchDateExtDn(Y, Dnr);
  3546.      finally
  3547.         DisableUserCalc(Dt);
  3548.      end;
  3549.  
  3550.      YExt := FetchYearExt(DateExt.Year);
  3551.      if DExt.Weeknumber = YExt.NumWeeks then
  3552.      begin
  3553.           TestYear := YExt.Year + 1;
  3554.           WExt := FetchWeekExt(TestYear,1);
  3555.           if (WExt.LastDay - WExt.FirstDay + 1) = 7 then
  3556.              TestWeek := 1
  3557.           else
  3558.              TestWeek := 2;
  3559.      end
  3560.      else
  3561.      begin
  3562.           TestYear := YExt.Year;
  3563.           TestWeek := DExt.Weeknumber + 1;
  3564.      end;
  3565.      AYear := TestYear;
  3566.      AWeeknumber := TestWeek;
  3567.      Result :=
  3568.      (FYear = TestYear)
  3569.      and (FWeek = TestWeek);
  3570. end;
  3571.  
  3572. function TKronos.IsLastWeek;
  3573. var
  3574.    Y, Dnr : Word;
  3575.    YExt : TYearExt;
  3576.    DExt : TDateExt;
  3577.    WExt : TWeekExt;
  3578.    TestWeek, TestYear : word;
  3579.    Dt : boolean;
  3580. begin
  3581.      IsToday(Y, Dnr);
  3582.      Dt := FCalcDisabled;
  3583.      DisableUserCalc(True);
  3584.      try
  3585.         DExt := FetchDateExtDn(Y, Dnr);
  3586.      finally
  3587.         DisableUserCalc(Dt);
  3588.      end;
  3589.      if DExt.Weeknumber = 1 then
  3590.      begin
  3591.           TestYear := Y - 1;
  3592.           YExt := FetchYearExt(TestYear);
  3593.           WExt := FetchWeekExt(TestYear,YExt.NumWeeks);
  3594.           if (WExt.LastDay - WExt.FirstDay + 1) = 7 then
  3595.             TestWeek := YExt.NumWeeks
  3596.           else
  3597.             TestWeek := YExt.NumWeeks - 1;
  3598.      end
  3599.      else
  3600.      begin
  3601.           TestYear := Y;
  3602.           TestWeek := DExt.Weeknumber - 1;
  3603.      end;
  3604.      AYear := TestYear;
  3605.      AWeeknumber := TestWeek;
  3606.      Result :=
  3607.      (FYear = TestYear)
  3608.      and (FWeek = TestWeek);
  3609. end;
  3610.  
  3611. function TKronos.IsThisMonth;
  3612. var
  3613.    A, M, D, Wd : word;
  3614.    T : TDatetime;
  3615.    DExt : TDateExt;
  3616.    Dt : boolean;
  3617. begin
  3618.      T := Date;
  3619.      DecodeDate(T, A, M, D);
  3620.      Dt := FCalcDisabled;
  3621.      DisableUserCalc(True);
  3622.      try
  3623.         DExt := FetchDateExt(A, M, D);
  3624.      finally
  3625.         DisableUserCalc(Dt);
  3626.      end;
  3627.      Result := (FYear = A)
  3628.      and (FMonth = DExt.MonthNumber);
  3629.      AYear := A;
  3630.      AMonthnumber := DExt.MonthNumber;
  3631. end;
  3632.  
  3633. function TKronos.IsNextMonth;
  3634. var
  3635.    TestYear, TestMonth : word;
  3636.    Y, Dnr : word;
  3637.    Dt : boolean;
  3638.    DExt : TDateExt;
  3639. begin
  3640.      IsToday(Y, Dnr);
  3641.      Dt := FCalcDisabled;
  3642.      DisableUserCalc(True);
  3643.      try
  3644.         DExt := FetchDateExtDn(Y, Dnr);
  3645.      finally
  3646.         DisableUserCalc(Dt);
  3647.      end;
  3648.      if DExt.Monthnumber = 12 then
  3649.      begin
  3650.           TestYear := Y + 1;
  3651.           TestMonth := 1;
  3652.      end
  3653.      else
  3654.      begin
  3655.           TestYear := Y;
  3656.           TestMonth := DExt.Monthnumber + 1;
  3657.      end;
  3658.      AYear := TestYear;
  3659.      AMonthnumber := TestMonth;
  3660.      Result :=
  3661.      (FYear = TestYear)
  3662.      and (FMonth = TestMonth);
  3663. end;
  3664.  
  3665. function TKronos.IsLastMonth;
  3666. var
  3667.    TestYear, TestMonth : word;
  3668.    Y, Dnr : word;
  3669.    Dt : boolean;
  3670.    DExt : TDateExt;
  3671. begin
  3672.      IsToday(Y, Dnr);
  3673.      Dt := FCalcDisabled;
  3674.      DisableUserCalc(True);
  3675.      try
  3676.         DExt := FetchDateExtDn(Y, Dnr);
  3677.      finally
  3678.         DisableUserCalc(Dt);
  3679.      end;
  3680.      if DExt.Monthnumber = 1 then
  3681.      begin
  3682.           TestYear := Y - 1;
  3683.           TestMonth := 12;
  3684.      end
  3685.      else
  3686.      begin
  3687.           TestYear := Y;
  3688.           TestMonth := DExt.Monthnumber - 1;
  3689.      end;
  3690.      AYear := TestYear;
  3691.      AMonthnumber := TestMonth;
  3692.      Result :=
  3693.      (FYear = TestYear)
  3694.      and (FMonth = TestMonth);
  3695. end;
  3696.  
  3697. function TKronos.IsThisYear;
  3698. var
  3699.    A, M, D : word;
  3700.    T : TDatetime;
  3701. begin
  3702.      T := Date;
  3703.      DecodeDate(T, A, M, D);
  3704.      Result := (FYear = A);
  3705.      AYear := A;
  3706. end;
  3707.  
  3708. function TKronos.IsNextYear;
  3709. var
  3710.    A, M, D : word;
  3711.    T : TDatetime;
  3712. begin
  3713.      T := Date;
  3714.      DecodeDate(T, A, M, D);
  3715.      Result := (FYear = (A + 1));
  3716.      AYear := A + 1;
  3717. end;
  3718.  
  3719. function TKronos.IsLastYear;
  3720. var
  3721.    A, M, D : word;
  3722.    T : TDatetime;
  3723. begin
  3724.      T := Date;
  3725.      DecodeDate(T, A, M, D);
  3726.      Result := (FYear = (A-1));
  3727.      AYear := A-1;
  3728. end;
  3729.  
  3730. function TKronos.IsLeapYear;
  3731. begin
  3732.      Result := IsLeap(AYear);
  3733. end;
  3734.  
  3735. function TKronos.IsLastDayOfMonth;
  3736. var
  3737.    M : TMonthExt;
  3738. begin
  3739.      Result := false;
  3740.      M := FetchMonthExt(AYear, AMonth);
  3741.      Result := (AMonthday = M.Numdays);
  3742. end;
  3743.  
  3744.  
  3745. function TKronos.IsLastWeekOfYear;
  3746. var
  3747.    Y : TYearExt;
  3748. begin
  3749.      Result := false;
  3750.      Y := FetchYearExt(AYear);
  3751.      Result := (AWeek = Y.NumWeeks);
  3752. end;
  3753.  
  3754.  
  3755. function TKronos.FindDayTypeId;
  3756. var
  3757.    i : integer;
  3758.    DT : TDaytype;
  3759.    Key : string;
  3760. begin
  3761.      Result := 0;
  3762.      Key := IntToStr(DaytypeId);
  3763.      for i := 1 to 6 - Length(Key) do Key := '0' + Key;
  3764.      if IdList.Find(Key,i) then
  3765.      begin
  3766.           DT := TDaytype(DateList.Objects[i]);
  3767.           if DT.UserCalc then
  3768.           begin
  3769.                Result := 367;
  3770.                exit;
  3771.           end;
  3772.           if DT.TheDate <> 0 then
  3773.           begin
  3774.                Result := ReadDaynr(DT.TheDate);
  3775.           end
  3776.           else if DT.Reldaytype <> 0 then
  3777.           begin
  3778.                Result := ChurchdayIndex[DT.RelDayType] +
  3779.                DT.Offset;
  3780.           end;
  3781.      end;
  3782. end;
  3783.  
  3784. function TKronos.FindDayType;
  3785. {Returns the daynumber}
  3786. var
  3787.    i : integer;
  3788.    DT : TDaytype;
  3789. begin
  3790.      Result := 0;
  3791.      if NameList.Find(Trim(AnsiUpperCase(DayTypeName)),i) then
  3792.      begin
  3793.           DT := TDaytype(NameList.Objects[i]);
  3794.           if DT.UserCalc then
  3795.           begin
  3796.                Result := 367;
  3797.                exit;
  3798.           end;
  3799.           if DT.TheDate <> 0 then
  3800.           begin
  3801.                Result := ReadDaynr(DT.TheDate);
  3802.           end
  3803.           else if DT.Reldaytype <> 0 then
  3804.           begin
  3805.                Result := ChurchdayIndex[DT.RelDayType] +
  3806.                DT.Offset;
  3807.           end;
  3808.      end;
  3809. end;
  3810.  
  3811. function TKronos.ExistsDaytype;
  3812. var
  3813.    i, ind : integer;
  3814.    DT : TDaytype;
  3815.    Found : boolean;
  3816.  
  3817. begin
  3818.      Result := 0;
  3819.      if NameList.Find(AnsiUppercase(Trim(DaytypeName)), Ind) then
  3820.      begin
  3821.           inc(Result);
  3822.           inc(Ind);
  3823.           Found := true;
  3824.           while Found and (Ind <= NameList.Count - 1) do
  3825.           begin
  3826.                DT := TDaytype(NameList.Objects[Ind]);
  3827.                if (AnsiUppercase(DT.TheName) =
  3828.                AnsiUpperCase(DayTypeName)) then
  3829.                begin
  3830.                     inc(Result);
  3831.                     inc(Ind);
  3832.                end
  3833.                else
  3834.                    Found := false;
  3835.           end;
  3836.      end;
  3837. end;
  3838.  
  3839. procedure TKronos.ReChange;
  3840. var
  3841.    D, A : word;
  3842. begin
  3843.      ChangeYear;
  3844.      ChangeMonth;
  3845.      ChangeMonthNumber;
  3846.      ChangeWeek;
  3847.      ChangeWeekNumber;
  3848.      ChangeDate;
  3849.      ChangeMonthDay;
  3850.      ChangeWeekday;
  3851.      if IsToDay(A, D) then
  3852.         Today;
  3853. end;
  3854.  
  3855. function TKronos.DaynumberByTypeName;
  3856. {Returns the daynumber of DayTypeName in AYear}
  3857. var
  3858.   De, Dt : boolean;
  3859.   OrigYear, OrigDayNr : word;
  3860. begin
  3861.      Result := 0;
  3862.      OrigYear := FYear;
  3863.      OrigDayNr := DayNumber;
  3864.      De := FEventsDisabled;
  3865.      Dt := FCalcDisabled;
  3866.      DisableEvents(True);
  3867.      DisableUserCalc(True);
  3868.      try
  3869.         Year := AYear;
  3870.         Result := FindDayType(DayTypeName);
  3871.      finally
  3872.         Year := OrigYear;
  3873.         DayNumber := OrigDayNr;
  3874.         DisableUserCalc(Dt);
  3875.         DisableEvents(De);
  3876.      end;
  3877. end;
  3878.  
  3879. function TKronos.DaynumberByTypeId;
  3880. {Returns the daynumber of ADayTypeConst in AYear}
  3881. var
  3882.   De, Dt : boolean;
  3883.   OrigYear, OrigDayNr : word;
  3884. begin
  3885.      Result := 0;
  3886.  
  3887.      OrigYear := FYear;
  3888.      OrigDayNr := DayNumber;
  3889.      De := FEventsDisabled;
  3890.      Dt := FCalcDisabled;
  3891.      DisableEvents(True);
  3892.      DisableUserCalc(True);
  3893.      try
  3894.         Year := AYear;
  3895.         Result := FindDayTypeId(ADayTypeId);
  3896.      finally
  3897.         Year := OrigYear;
  3898.         DayNumber := OrigDayNr;
  3899.         DisableEvents(De);
  3900.         DisableUserCalc(Dt);
  3901.      end;
  3902. end;
  3903.  
  3904.  
  3905. procedure TKronos.GotoDate;
  3906. var
  3907.    ic : boolean;
  3908. begin
  3909.      ic := FChanging;
  3910.      BeginChange;
  3911.      try
  3912.         Year := AYear;
  3913.         Month := AMonth;
  3914.         Monthday := AMonthday;
  3915.      finally
  3916.         if not ic then
  3917.           EndChange;
  3918.      end;
  3919.      // if there is a transaction already running don't end
  3920. end;
  3921.  
  3922. procedure TKronos.GotoDateDt;
  3923. var
  3924.    Y, M, D, Wd : word;
  3925. begin
  3926.      DecodeDate(ADate, Y, M, D);
  3927.      GotoDate(Y, M, D);
  3928. end;
  3929.  
  3930. procedure TKronos.GotoDateDn;
  3931. var
  3932.    ic : boolean;
  3933. begin
  3934.      ic := FChanging;
  3935.      BeginChange;
  3936.      try
  3937.         Year := AYear;
  3938.         Daynumber := ADaynumber;
  3939.      finally
  3940.         if not ic then
  3941.            EndChange;
  3942.      end;
  3943. end;
  3944.  
  3945. procedure TKronos.GotoToday;
  3946. var
  3947.    Y, M, D, Wd : word;
  3948.    ic : boolean;
  3949.   begin
  3950.      if IsToday(Y,D) then exit;
  3951.      GetDate(Y, M, D, Wd);
  3952.      ic := FChanging;
  3953.      BeginChange;
  3954.      try
  3955.         Year := Y;
  3956.         Month := M;
  3957.         MonthDay := D;
  3958.      finally
  3959.         if not ic then
  3960.            EndChange;
  3961.      end;
  3962. end;
  3963.  
  3964. procedure TKronos.GotoTomorrow;
  3965. var
  3966.    De, Dt, ic : boolean;
  3967.    Dnr, Y : word;
  3968. begin
  3969.      if IsTomorrow(Y, Dnr) then exit;
  3970.      De := FEventsDisabled;
  3971.      Dt := FCalcDisabled;
  3972.      SaveIntCD;
  3973.      DisableEvents(True);
  3974.      DisableUserCalc(True);
  3975.      try
  3976.         GotoToDay;
  3977.         GotoOffsetDay(1, false);
  3978.         DNr := DayNumber;
  3979.         Y := Year;
  3980.      finally
  3981.         RestoreIntCD;
  3982.         DisableEvents(De);
  3983.         DisableUserCalc(Dt);
  3984.      end;
  3985.      GotoDateDn(Y, Dnr);
  3986. end;
  3987.  
  3988. procedure TKronos.GotoYesterday;
  3989. var
  3990.    De, Dt : boolean;
  3991.    Dnr, Y : word;
  3992. begin
  3993.      if IsYesterday(Y, Dnr) then exit;
  3994.      De := FEventsDisabled;
  3995.      Dt := FCalcDisabled;
  3996.      SaveIntCD;
  3997.      DisableEvents(True);
  3998.      DisableUserCalc(True);
  3999.      try
  4000.         GotoToDay;
  4001.         GotoOffsetDay(-1, false);
  4002.         DNr := DayNumber;
  4003.         Y := Year;
  4004.      finally
  4005.         RestoreIntCD;
  4006.         DisableEvents(De);
  4007.         DisableUserCalc(Dt);
  4008.      end;
  4009.      GotoDateDn(Y, Dnr);
  4010. end;
  4011.  
  4012. procedure TKronos.GotoThisWeek;
  4013. var
  4014.    De, Dt : boolean;
  4015.    TestWeek,TestYear : word;
  4016.    WeekCount : integer;
  4017.    A, W : word;
  4018. begin
  4019.      if IsThisWeek(A, W) then exit;
  4020.      De := FEventsDisabled;
  4021.      Dt := FCalcDisabled;
  4022.      DisableEvents(True);
  4023.      DisableUserCalc(True);
  4024.      SaveIntCD;
  4025.      try
  4026.         try
  4027.            GotoToDay;
  4028.            TestWeek := FWeek;
  4029.            TestYear := FYear;
  4030.         finally
  4031.             RestoreIntCD;
  4032.             DisableEvents(De);
  4033.         end;
  4034.         WeekCount := WeeksInInterval(FYear, FWeek, TestYear, TestWeek);
  4035.      finally
  4036.         DisableUserCalc(Dt);
  4037.      end;
  4038.      GotoOffsetWeek(WeekCount);
  4039. end;
  4040.  
  4041. procedure TKronos.GotoNextWeek;
  4042. var
  4043.    De, Dt : boolean;
  4044.    TestWeek, TestYear : word;
  4045.    WeekCount : integer;
  4046.    A, W : word;
  4047. begin
  4048.      if IsNextWeek(A,W) then exit;
  4049.      De := FEventsDisabled;
  4050.      Dt := FCalcDisabled;
  4051.      DisableEvents(True);
  4052.      SaveIntCD;
  4053.      try
  4054.         GotoToDay;
  4055.         GotoOffsetWeek(1);
  4056.         TestWeek := FWeek;
  4057.         TestYear := FYear;
  4058.      finally
  4059.         RestoreIntCD;
  4060.         DisableEvents(De);
  4061.      end;
  4062.      WeekCount := WeeksInInterval(FYear, FWeek, TestYear, TestWeek);
  4063.      GotoOffsetWeek(WeekCount);
  4064. end;
  4065.  
  4066. procedure TKronos.GotoLastWeek;
  4067. var
  4068.    De, Dt : boolean;
  4069.    OrigYear, OrigWeek, TestWeek,
  4070.    TestYear, OrigDayNr : word;
  4071.    WeekCount : integer;
  4072.    A, W : word;
  4073. begin
  4074.      if IsLastWeek(A, W) then exit;
  4075.      De := FEventsDisabled;
  4076.      Dt := FCalcDisabled;
  4077.      DisableEvents(True);
  4078.      DisableUserCalc(True);
  4079.      SaveIntCD;
  4080.      try
  4081.         try
  4082.            GotoToDay;
  4083.            GotoOffsetWeek(-1);
  4084.            TestWeek := FWeek;
  4085.            TestYear := FYear;
  4086.         finally
  4087.            RestoreIntCD;
  4088.            DisableEvents(De);
  4089.         end;
  4090.         WeekCount := WeeksInInterval(FYear, FWeek, TestYear, TestWeek);
  4091.      finally
  4092.         DisableUserCalc(Dt);
  4093.      end;
  4094.      GotoOffsetWeek(WeekCount);
  4095. end;
  4096.  
  4097. procedure TKronos.GotoThisMonth;
  4098. var
  4099.    De, Dt : boolean;
  4100.    OrigYear, OrigMonth, TestMonth,
  4101.    TestYear, OrigDayNr : word;
  4102.    MonthCount : integer;
  4103.    A, M : word;
  4104. begin
  4105.      if IsThisMonth(A, M) then exit;
  4106.      De := FEventsDisabled;
  4107.      Dt := FCalcDisabled;
  4108.      DisableEvents(True);
  4109.      DisableUserCalc(True);
  4110.      OrigYear := FYear;
  4111.      OrigMonth := FMonth;
  4112.      OrigDayNr := FDayNumber;
  4113.      try
  4114.         try
  4115.            GotoToDay;
  4116.            TestMonth := FMonth;
  4117.            TestYear := FYear;
  4118.         finally
  4119.            Year := OrigYear;
  4120.            DayNumber := OrigDayNr;
  4121.            DisableEvents(De);
  4122.         end;
  4123.         MonthCount := MonthsInInterval
  4124.         (FYear, FMonth, TestYear, TestMonth);
  4125.      finally
  4126.         DisableUserCalc(Dt);
  4127.      end;
  4128.      GotoOffsetMonth(MonthCount);
  4129. end;
  4130.  
  4131. procedure TKronos.GotoNextMonth;
  4132. var
  4133.    De, Dt : boolean;
  4134.    OrigYear, OrigMonth, TestMonth,
  4135.    TestYear, OrigDayNr : word;
  4136.    MonthCount : integer;
  4137.    A, M : word;
  4138. begin
  4139.      if IsNextMonth(A, M) then exit;
  4140.      De := FEventsDisabled;
  4141.      Dt := FCalcDisabled;
  4142.      DisableEvents(True);
  4143.      DisableUserCalc(True);
  4144.      OrigYear := FYear;
  4145.      OrigMonth := FMonth;
  4146.      OrigDayNr := FDayNumber;
  4147.      try
  4148.         try
  4149.            GotoToDay;
  4150.            GotoOffsetMonth(1);
  4151.            TestMonth := FMonth;
  4152.            TestYear := FYear;
  4153.         finally
  4154.            Year := OrigYear;
  4155.            DayNumber := OrigDayNr;
  4156.            DisableEvents(De);
  4157.         end;
  4158.         MonthCount := MonthsInInterval
  4159.         (FYear, FMonth, TestYear, TestMonth);
  4160.      finally
  4161.         DisableUserCalc(Dt);
  4162.      end;
  4163.      GotoOffsetMonth(MonthCount);
  4164. end;
  4165.  
  4166. procedure TKronos.GotoLastMonth;
  4167. var
  4168.    De, Dt : boolean;
  4169.    OrigYear, OrigMonth, TestMonth,
  4170.    TestYear, OrigDayNr : word;
  4171.    MonthCount : integer;
  4172.    A, M : word;
  4173. begin
  4174.      if IsLastMonth(A, M) then exit;
  4175.      De := FEventsDisabled;
  4176.      Dt := FCalcDisabled;
  4177.      DisableEvents(True);
  4178.      DisableUserCalc(True);
  4179.      OrigYear := FYear;
  4180.      OrigMonth := FMonth;
  4181.      OrigDayNr := FDayNumber;
  4182.      try
  4183.         try
  4184.            GotoToDay;
  4185.            GotoOffsetMonth(-1);
  4186.            TestMonth := FMonth;
  4187.            TestYear := FYear;
  4188.         finally
  4189.             Year := OrigYear;
  4190.             DayNumber := OrigDayNr;
  4191.             DisableEvents(De);
  4192.         end;
  4193.         MonthCount := MonthsInInterval
  4194.         (FYear, FMonth, TestYear, TestMonth);
  4195.      finally
  4196.          DisableUserCalc(Dt);
  4197.      end;
  4198.      GotoOffsetMonth(MonthCount);
  4199. end;
  4200.  
  4201. procedure TKronos.GotoDayType;
  4202. {Moves to the daynumber of DayTypeName/Id}
  4203. var
  4204.    De, Dt, ic : boolean;
  4205.    DayNr : word;
  4206.    TrYear : boolean;
  4207.    OrigDayNr, OrigYear : word;
  4208. begin
  4209.      OrigYear := FYear;
  4210.      OrigDayNr := FDayNumber;
  4211.      De := FEventsDisabled;
  4212.      Dt := FCalcDisabled;
  4213.      DisableEvents(True);
  4214.      DisableUserCalc(True);
  4215.      TrYear := false;
  4216.      try
  4217.         if AYear <> Year then
  4218.         begin
  4219.           Year := AYear;
  4220.           TrYear := true;
  4221.         end;
  4222.         if AnId = 0 then
  4223.            DayNr := FindDayType(DayTypeName)
  4224.         else
  4225.            DayNr := FindDaytypeId(AnId);
  4226.  
  4227.         if (DayNr = 0)
  4228.         or (Daynr = 367) then
  4229.         begin
  4230.           Year := OrigYear;
  4231.           DayNumber := OrigDayNr;
  4232.           DisableEvents(De);
  4233.           DisableUserCalc(Dt);
  4234.           FTransError := FChanging;
  4235.           if FTransError then EndChange;
  4236.           if Daynr = 0 then
  4237.              raise EKronosError.Create
  4238.              ('Daytype ' + DayTypeName +  ' not found')
  4239.           else
  4240.              raise EKronosError.Create
  4241.              ('Daytype ' + DayTypeName +  ' is calculated by user');
  4242.         end;
  4243.      finally
  4244.         DisableEvents(De);
  4245.         DisableUserCalc(Dt);
  4246.      end;
  4247.  
  4248.      ic := FChanging;
  4249.      BeginChange;
  4250.      if TrYear then
  4251.      begin
  4252.         ChangeYear;
  4253.         ChangeMonth;
  4254.         ChangeWeek;
  4255.      end;
  4256.      try
  4257.         DayNumber := DayNr;
  4258.      finally
  4259.         if not ic then
  4260.           EndChange;
  4261.      end;
  4262. end;
  4263.  
  4264. function TKronos.DaysInInterval;
  4265. {Count number of days between Year1, Monthday1 and Year2, Monthday2.}
  4266. var
  4267.    Factor : shortint;
  4268.    Counter : integer;
  4269.    Antall : integer;
  4270.    Dt : boolean;
  4271.    T1, T2 : TDateTime;
  4272.    DE : TDateExt;
  4273.    YE : TYearExt;
  4274.    Y : Word;
  4275.    DayNr : word;
  4276. begin
  4277.      Result := 0;
  4278.      Antall := 0;
  4279.  
  4280.      T1 := EncodeDate(Year1,Month1,MonthDay1);
  4281.      T2 := EncodeDate(Year2,Month2,MonthDay2);
  4282.      Antall := Trunc(T2) - Trunc(T1);
  4283.  
  4284.      if not WorkdaysOnly then
  4285.      begin
  4286.           Result := Antall;
  4287.           exit;
  4288.      end;
  4289.  
  4290.      if Antall = 0 then exit;
  4291.      if (Antall < 0) then
  4292.          Factor := -1
  4293.      else
  4294.          Factor := 1;
  4295.  
  4296.      Counter := 0;
  4297.  
  4298.      Dt := FCalcDisabled;
  4299.      DisableUserCalc(True);
  4300.  
  4301.      if T2 > T1 then
  4302.      begin
  4303.         DE := FetchDateExtDt(T1);
  4304.         YE := FetchYearExt(Year1);
  4305.      end
  4306.  
  4307.      else
  4308.      begin
  4309.         DE := FetchDateExtDt(T2);
  4310.         YE := FetchYearExt(Year2);
  4311.      end;
  4312.      Y := YE.Year;
  4313.      DayNr := DE.DayNumber;
  4314.  
  4315.      try
  4316.         while Counter <> Antall do
  4317.         begin
  4318.           if (DayNr + Factor) > YE.NumDays then
  4319.           begin
  4320.                Y := Y + Factor;
  4321.                YE := FetchYearExt(Y);
  4322.                DE := FetchDateExtDn(Y,1);
  4323.                DayNr := 1;
  4324.           end
  4325.           else if (DayNr + Factor) < 1 then
  4326.           begin
  4327.                Y := Y + Factor;
  4328.                YE := FetchYearExt(Y);
  4329.                DayNr := YE.NumDays;
  4330.                DE := FetchDateExtDn(Y,DayNr);
  4331.           end
  4332.           else
  4333.           begin
  4334.               DayNr := DayNr + Factor;
  4335.               DE := FetchDateExtDn(Y,DayNr);
  4336.           end;
  4337.           if not DE.Holiday then
  4338.              Result := Result + Factor;
  4339.           Counter := Counter + Factor;
  4340.         end;
  4341.  
  4342.      finally
  4343.             DisableUserCalc(Dt);
  4344.      end;
  4345. end;
  4346.  
  4347. function TKronos.DaysInIntervalDt;
  4348. var
  4349.    AYear1, AMonth1, ADate1 : word;
  4350.    AYear2, AMonth2, ADate2 : word;
  4351. begin
  4352.      DecodeDate(Date1, Ayear1, AMonth1, ADate1);
  4353.      DecodeDate(Date2, Ayear2, AMonth2, ADate2);
  4354.      Result := DaysInInterval(AYear1, AMonth1, ADate1,
  4355.      AYear2, AMonth2, ADate2, WorkdaysOnly);
  4356. end;
  4357.  
  4358. function TKronos.DaysInIntervalDn;
  4359. var
  4360.    AMonth1, ADate1 : word;
  4361.    AMonth2, ADate2 : word;
  4362.    DExt1, DExt2 : TDateExt;
  4363. begin
  4364.      DExt1 := FetchDateExtDn(Year1, Daynumber1);
  4365.      AMonth1 := DExt1.MonthNumber;
  4366.      ADate1 := DExt1.MonthDay;
  4367.      DExt2 := FetchDateExtDn(Year2, Daynumber2);
  4368.      AMonth2 := DExt2.MonthNumber;
  4369.      ADate2 := DExt2.MonthDay;
  4370.  
  4371.      Result := DaysInInterval(Year1, AMonth1, ADate1,
  4372.      Year2, AMonth2, ADate2, WorkdaysOnly);
  4373. end;
  4374.  
  4375.  
  4376. function TKronos.WeeksInInterval;
  4377. {Count number of weeks between Year1, Week1 and Year2, Week2.}
  4378. var
  4379.    Factor : shortint;
  4380.    Y1, Y2, W1, W2 : word;
  4381.    WExt1, WExt2 : TWeekExt;
  4382.    DaysInt : Integer;
  4383. begin
  4384.      Result := 0;
  4385.  
  4386.      if Year2 < Year1 then
  4387.      begin
  4388.           Y1 := Year2;
  4389.           Y2 := Year1;
  4390.           W2 := Week1;
  4391.           W1 := Week2;
  4392.           Factor := -1;
  4393.      end
  4394.      else if (Year2 = Year1) and (Week2 < Week1) then
  4395.      begin
  4396.           Y1 := Year1;
  4397.           Y2 := Year2;
  4398.           W1 := Week2;
  4399.           W2 := Week1;
  4400.           Factor := -1;
  4401.      end
  4402.      else
  4403.      begin
  4404.           Y1 := Year1;
  4405.           Y2 := Year2;
  4406.           W1 := Week1;
  4407.           W2 := Week2;
  4408.           Factor := 1;
  4409.      end;
  4410.  
  4411.      WExt1 := FetchWeekExt(Y1, W1);
  4412.      WExt2 := FetchWeekExt(Y2, W2);
  4413.      DaysInt := DaysInIntervalDn(Y1, WExt1.FirstDay, Y2, WExt2.FirstDay,
  4414.      false);
  4415.      Result := (DaysInt div 7) * Factor;
  4416. end;
  4417.  
  4418. function TKronos.MonthsInInterval;
  4419. {Count number of months between Year1, Month1 and Year2, Month2.}
  4420. var
  4421.    Factor : shortint;
  4422.    Y1, Y2, M1, M2 : word;
  4423.    MndNr : word;
  4424.    Aar : word;
  4425.    Antall, AntMnd : integer;
  4426. begin
  4427.      Result := 0;
  4428.      Antall := 0;
  4429.  
  4430.      if Year2 < Year1 then
  4431.      begin
  4432.           Y1 := Year2;
  4433.           Y2 := Year1;
  4434.           M1 := Month2;
  4435.           M2 := Month1;
  4436.           Factor := -1;
  4437.      end
  4438.      else if (Year2 = Year1) and (Month2 < Month1) then
  4439.      begin
  4440.           Y1 := Year1;
  4441.           Y2 := Year2;
  4442.           M1 := Month2;
  4443.           M2 := Month1;
  4444.           Factor := -1;
  4445.      end
  4446.      else
  4447.      begin
  4448.           Y1 := Year1;
  4449.           Y2 := Year2;
  4450.           M1 := Month1;
  4451.           M2 := Month2;
  4452.           Factor := 1;
  4453.      end;
  4454.  
  4455.      Aar := Y1;
  4456.  
  4457.      if ((M1 > 12) or (M1 = 0))
  4458.      or  ((M2 > 12) or (M2 = 0)) then
  4459.      begin
  4460.           raise EKronosError.Create(c_MonthOutofBounds);
  4461.      end;
  4462.  
  4463.      MndNr := M1;
  4464.  
  4465.      while not ((Aar = Y2) and (MndNr = M2)) do
  4466.      begin
  4467.            inc(Antall);
  4468.            if MndNr = 12 then
  4469.            begin
  4470.                 inc(Aar);
  4471.                 MndNr := 1;
  4472.            end
  4473.            else
  4474.            begin
  4475.                 inc(MndNr);
  4476.            end;
  4477.      end;
  4478.  
  4479.      Result := Antall * Factor;
  4480. end;
  4481.  
  4482.  
  4483. procedure TKronos.FindOffsetDay;
  4484. {Returns the day and year by counting offset-days from current day}
  4485. var
  4486.    Factor : shortint;
  4487.    Antall : integer;
  4488.    Counter : integer;
  4489.    T : TDateTime;
  4490.    M, D : word;
  4491.    DE : TDateExt;
  4492.    YE : TYearExt;
  4493.    DayNr : word;
  4494.    Y : word;
  4495.    OrigYear, OrigDaynr : word;
  4496.    Dsbl, Dt : Boolean;
  4497. begin
  4498.      Dsbl := FEventsDisabled;
  4499.      Dt := FCalcDisabled;
  4500.      if not WorkdaysOnly then
  4501.      begin
  4502.           T := CDToDateTime;
  4503.           T := T + OffsetValue;
  4504.           DecodeDate(T, TheYear, M, D);
  4505.           if (TheYear > FMaxYear)
  4506.           or (TheYear < FMinYear) then
  4507.           begin
  4508.                raise EKronosError.Create(c_YearOutOfBounds);
  4509.           end;
  4510.           DE := FetchDateExtDt(T);
  4511.           TheDayNumber := DE.DayNumber;
  4512.           exit;
  4513.      end;
  4514.  
  4515.      if (OffsetValue < 0) then
  4516.          Factor := -1
  4517.      else
  4518.          Factor := 1;
  4519.  
  4520.      OrigYear := FYear;
  4521.      OrigDayNr := FDaynumber;
  4522.  
  4523.      DE := FDateExt;
  4524.      YE := FYearExt;
  4525.      DayNr := FDaynumber;
  4526.      Y := FYear;
  4527.      Counter := 0;
  4528.  
  4529.      DisableEvents(True);
  4530.      DisableUserCalc(True);
  4531.      try
  4532.      while Counter <> OffsetValue do
  4533.      begin
  4534.           if (DayNr + Factor) > YE.NumDays then
  4535.           begin
  4536.                Y := Y + Factor;
  4537.                Year := Y;
  4538.                YE := FYearExt;
  4539.                DE := FetchDateExtDn(FYear,1);
  4540.                DayNr := 1;
  4541.           end
  4542.           else if (DayNr + Factor) < 1 then
  4543.           begin
  4544.                Y := Y + Factor;
  4545.                Year := Year + Factor;
  4546.                YE := FYearExt;
  4547.                DayNr := YE.NumDays;
  4548.                DE := FetchDateExtDn(FYear,YE.Numdays);
  4549.           end
  4550.           else
  4551.           begin
  4552.               DayNr := DayNr + Factor;
  4553.               DE := FetchDateExtDn(Y,Daynr);
  4554.           end;
  4555.           if not DE.Holiday then
  4556.              Counter := Counter + Factor;
  4557.      end;
  4558.      finally
  4559.           Year := OrigYear;
  4560.           Daynumber := OrigDayNr;
  4561.           DisableEvents(Dsbl);
  4562.           DisableUserCalc(Dt);
  4563.      end;
  4564.      TheYear := Y;
  4565.      TheDayNumber := DayNr;
  4566. end;
  4567.  
  4568. procedure TKronos.FindOffsetWeek;
  4569. var
  4570.    nDays : integer;
  4571. begin
  4572.      nDays := OffsetValue * 7;
  4573.      FindOffsetDay(TheYear, TheDayNumber, nDays, false);
  4574. end;
  4575.  
  4576. procedure TKronos.FindOffsetMonth;
  4577. var
  4578.    Rest : integer;
  4579.    Factor : integer;
  4580.    Y, M : word;
  4581.    IsLeft : integer;
  4582.    OrigYear, OrigDayNr : word;
  4583.    De, Dt : boolean;
  4584. begin
  4585.      if OffsetValue < 0 then
  4586.         Factor := -1
  4587.      else
  4588.         Factor := 1;
  4589.  
  4590.      if Factor < 0 then
  4591.         Rest := FMonth - 1
  4592.      else
  4593.         Rest := 12 - FMonth;
  4594.  
  4595.      OrigYear := Year;
  4596.      OrigDayNr := DayNumber;
  4597.  
  4598.      De := FEventsDisabled;
  4599.      Dt := FCalcDisabled;
  4600.      DisableEvents(True);
  4601.      DisableUserCalc(True);
  4602.      try
  4603.        IsLeft := Abs(OffsetValue) - Rest;
  4604.        //Gjenstσende utover innevµrende σr
  4605.        if IsLeft <= 0 then
  4606.        begin
  4607.           Month := Month + OffsetValue;
  4608.        end
  4609.        else
  4610.        begin
  4611.           Y := IsLeft div 12;
  4612.           //Antall hele σr i Gjenstσende
  4613.           Year := Year + (Y * Factor);
  4614.           M := IsLeft mod 12;
  4615.           //Antall mσneder utover hele σr
  4616.           if M > 0 then
  4617.           begin
  4618.                Year := Year + Factor;
  4619.                if Factor < 0 then
  4620.                   Month := 13 - M
  4621.                else
  4622.                   Month := M;
  4623.           end
  4624.           else
  4625.           begin
  4626.               if Factor > 0 then
  4627.                  Month := 12
  4628.               else
  4629.                  Month := 1;
  4630.           end;
  4631.        end;
  4632.  
  4633.        TheYear := Year;
  4634.        TheDayNumber := DayNumber;
  4635.      finally
  4636.        Year := OrigYear;
  4637.        DayNumber := OrigDayNr;
  4638.        DisableEvents(De);
  4639.        DisableUserCalc(Dt);
  4640.      end;
  4641. end;
  4642.  
  4643. function TKronos.GetDow;
  4644. var
  4645.    FirstDay : word;
  4646. begin
  4647.      FirstDay := Ord(FFirstWeekDay);
  4648.      if FirstDay = 0 then FirstDay := 7;
  4649.      Result := 7 - (FirstDay - DNr) + 1;
  4650.      if Result > 7 then
  4651.      Result := Result -7;
  4652. end;
  4653.  
  4654. function TKronos.ConvertWeekday;
  4655. {Converts a dow number of type 1=Monday, 2=Sunday to type TWeekDay}
  4656. begin
  4657.      Result := Sunday;
  4658.      if DayOfWeekNumber <> 7 then
  4659.         Result := TWeekDay(DayOfWeekNumber);
  4660. end;
  4661.  
  4662. procedure TKronos.GoToOffsetWeek;
  4663. var
  4664.    TheYear, TheDayNumber : word;
  4665.    ic : boolean;
  4666. begin
  4667.      FindOffsetWeek(TheYear, TheDayNumber, OffsetValue);
  4668.  
  4669.      ic := FChanging;
  4670.      BeginChange;
  4671.      if Year <> TheYear then
  4672.      begin
  4673.           Year := TheYear;
  4674.           if DayNumber <> TheDayNumber then
  4675.              DayNumber := TheDayNumber;
  4676.      end
  4677.      else if DayNumber <> TheDayNumber then
  4678.           DayNumber := TheDayNumber;
  4679.      if not ic then
  4680.         EndChange;
  4681. end;
  4682.  
  4683. procedure TKronos.GotoOffsetMonth;
  4684. var
  4685.    TheYear, TheDayNumber : word;
  4686.    ic : boolean;
  4687. begin
  4688.      FindOffsetMonth(TheYear, TheDayNumber, OffsetValue);
  4689.  
  4690.      ic := FChanging;
  4691.      BeginChange;
  4692.      try
  4693.         if Year <> TheYear then
  4694.         begin
  4695.           Year := TheYear;
  4696.           if DayNumber <> TheDayNumber then
  4697.              DayNumber := TheDayNumber;
  4698.         end
  4699.         else if DayNumber <> TheDayNumber then
  4700.           DayNumber := TheDayNumber;
  4701.      finally
  4702.         if not ic then
  4703.            EndChange;
  4704.      end;
  4705. end;
  4706.  
  4707. procedure TKronos.GoToOffsetDay;
  4708. {Sets the current day acc. to OffsetValue with starting point in current date}
  4709. var
  4710.    AYear, ADayNr : word;
  4711.    ic : boolean;
  4712. begin
  4713.      try
  4714.         FindOffsetDay(AYear, ADayNr, OffsetValue, WorkdaysOnly);
  4715.      except
  4716.         FTransError := FChanging;
  4717.         //if FTransError then EndChange;
  4718.         raise;
  4719.      end;
  4720.  
  4721.      ic := FChanging;
  4722.      BeginChange;
  4723.      try
  4724.         if AYear <> Year then
  4725.         begin
  4726.              Year := AYear;
  4727.              DayNumber := ADayNr;
  4728.         end
  4729.         else if ADayNr <> DayNumber then
  4730.              DayNumber := ADayNr;
  4731.      finally
  4732.         if not ic then
  4733.            EndChange;
  4734.      end;
  4735. end;
  4736.  
  4737. procedure TKronos.DateByWeekOffset;
  4738. begin
  4739.      FindOffsetWeek(TheYear, TheDayNumber, OffsetValue);
  4740. end;
  4741.  
  4742. procedure TKronos.DateByMonthOffset;
  4743. begin
  4744.      FindOffsetMonth(TheYear, TheDayNumber, OffsetValue);
  4745. end;
  4746.  
  4747. procedure TKronos.DateByDayOffset;
  4748. {Counts the days acc. to OffsetValue with starting point in current date.
  4749. Returns year and daynumber}
  4750. begin
  4751.      FindOffsetDay(TheYear, TheDayNumber, OffsetValue, WorkDaysOnly);
  4752. end;
  4753.  
  4754. function TKronos.FetchYearExt;
  4755. var
  4756.    OrigYear : word;
  4757.    DayC : TDayCodes;
  4758.    Cl : TCal;
  4759. begin
  4760.      OrigYear := Year;
  4761.      if (AYear > FMaxYear)
  4762.      or (AYear < FMinYear) then
  4763.         raise EKronosError.Create(c_YearOutOfBounds);
  4764.      if AYear <> FYear then
  4765.      begin
  4766.           Cl := Cal;
  4767.           DayC := DayCodes;
  4768.           ChangeKron(AYear);
  4769.           FYear := AYear;
  4770.           SetYearExt;
  4771.      end;
  4772.      Result := FYearExt;
  4773.  
  4774.      if (OrigYear <> FYear) then
  4775.      begin
  4776.            //ChangeKron(OrigYear);
  4777.            DayCodes := DayC;
  4778.            Cal := Cl;
  4779.            Kron.ActiveYear := OrigYear;
  4780.            FYear := OrigYear;
  4781.            SetYearExt;
  4782.      end;
  4783. end;
  4784.  
  4785. function TKronos.FetchMonthExt;
  4786. var
  4787.    OrigYear, OrigMonth : word;
  4788.    Cl :TCal;
  4789.    DayC : TDayCodes;
  4790. begin
  4791.      OrigYear := FYear;
  4792.      OrigMonth := FMonth;
  4793.      if (AYear > FMaxYear)
  4794.      or (AYear < FMinYear) then
  4795.         raise EKronosError.Create(c_YearOutOfBounds);
  4796.      if (AMonth > 12) or (AMonth < 1) then
  4797.         raise EKronosError.Create(c_MonthOutOfBounds);
  4798.  
  4799.      if AYear <> FYear then
  4800.      begin
  4801.           Cl := Cal;
  4802.           DayC := DayCodes;
  4803.           ChangeKron(AYear);
  4804.           FYear := AYear;
  4805.           SetYearExt;
  4806.      end;
  4807.  
  4808.      try
  4809.         FMonth := AMonth;
  4810.         SetMonthExt;
  4811.         Result := FMonthExt;
  4812.      finally
  4813.         if OrigYear <> FYear then
  4814.         begin
  4815.              //ChangeKron(OrigYear);
  4816.              Cal := Cl;
  4817.              DayCodes := Dayc;
  4818.              Kron.ActiveYear := OrigYear;
  4819.              FYear := OrigYear;
  4820.              SetYearExt;
  4821.         end;
  4822.         FMonth := OrigMonth;
  4823.         SetMonthExt;
  4824.      end;
  4825. end;
  4826.  
  4827. function TKronos.FetchWeekExt;
  4828. var
  4829.    OrigYear, OrigWeek : word;
  4830.    A : TYear;
  4831.    Cl : TCal;
  4832.    DayC : TDayCodes;
  4833. begin
  4834.      OrigYear := FYear;
  4835.      OrigWeek := FWeek;
  4836.      if (AYear > FMaxYear)
  4837.      or (AYear < FMinYear) then
  4838.         raise EKronosError.Create(c_YearOutOfBounds);
  4839.      if AYear <> FYear then
  4840.      begin
  4841.         Cl := Cal;
  4842.         DayC := DayCodes;
  4843.         ChangeKron(AYear);
  4844.      end;
  4845.      A := ReadYear;
  4846.      try
  4847.         if (AWeek > A.WeekCount) or (AWeek < 1) then
  4848.            raise EKronosError.Create(c_WeekOutOfBounds);
  4849.         FWeek := AWeek;
  4850.         FYear := AYear;
  4851.         SetWeekExt;
  4852.         Result := FWeekExt;
  4853.      finally
  4854.         if OrigYear <> FYear then
  4855.         begin
  4856.              //ChangeKron(FYear);
  4857.              Cal := Cl;
  4858.              DayCodes := DayC;
  4859.              Kron.ActiveYear := OrigYear;
  4860.         end;
  4861.         FWeek := OrigWeek;
  4862.         FYear := OrigYear;
  4863.         SetWeekext;
  4864.      end;
  4865. end;
  4866.  
  4867. function TKronos.FetchDateExt;
  4868. var
  4869.    OrigYear, OrigDayNr : word;
  4870.    origMonth, OrigMonthDay : word;
  4871.    M : TMonth;
  4872.    DayC : TDayCodes;
  4873.    Cl : TCal;
  4874. begin
  4875.      OrigYear := FYear;
  4876.      OrigDayNr := FDayNumber;
  4877.      OrigMonth := FMonth;
  4878.      OrigMonthday := FMonthday;
  4879.  
  4880.      if (AYear > FMaxYear)
  4881.      or (AYear < FMinYear) then
  4882.         raise EKronosError.Create(c_YearOutOfBounds);
  4883.      if (AMonth > 12)
  4884.      or (AMonth < 1) then
  4885.         raise EKronosError.Create(c_MonthOutOfBounds);
  4886.  
  4887.      try
  4888.         if FYear <> AYear then
  4889.         begin
  4890.            Cl := Cal;
  4891.            DayC := DayCodes;
  4892.            ChangeKron(AYear);
  4893.         end;
  4894.         M := ReadMonth(AMonth);
  4895.         if AMonthday > M.Daycount then
  4896.         begin
  4897.            raise EKronosError.Create(c_MonthdayOutofBounds);
  4898.         end;
  4899.         FYear := AYear;
  4900.         FMonth := AMonth;
  4901.         FMonthDay := AMonthDay;
  4902.         FDaynumber := ReadDayNr(AMonth*100+AMonthday);
  4903.         SetDateExt(OrigYear, OrigMonth, OrigMonthDay, OrigDaynr,
  4904.         Cl, DayC);
  4905.         Result := FDateExt;
  4906.      finally
  4907.         if OrigYear <> FYear then
  4908.         begin
  4909.              Cal := Cl;
  4910.              DayCodes := DayC;
  4911.              Kron.ActiveYear := OrigYear;
  4912.         end;
  4913.         FYear := OrigYear;
  4914.         FMonth := OrigMonth;
  4915.         FMonthDay := OrigMonthday;
  4916.         FDaynumber := OrigDaynr;
  4917.         SetDateExt(0,0,0,0, Cal, DayCodes);
  4918.      end;
  4919. end;
  4920.  
  4921. function TKronos.FetchDateExtDt;
  4922. var
  4923.    AYear, AMonth, AnDate : word;
  4924. begin
  4925.      DecodeDate(ADate, Ayear, AMonth, AnDate);
  4926.      Result := FetchDateExt(AYear, AMonth, AnDate);
  4927. end;
  4928.  
  4929. function TKronos.FetchDateExtDn;
  4930. var
  4931.    M, Md : word;
  4932.    T1, T2 : TDatetime;
  4933. begin
  4934.      if (AYear > FMaxYear)
  4935.      or (AYear < FMinYear) then
  4936.         raise EKronosError.Create(c_YearOutOfBounds);
  4937.      if IsLeap(AYear) then
  4938.      begin
  4939.           if (ADaynumber > 366) or (ADaynumber < 1) then
  4940.              raise EKronosError.Create(c_DaynumberOutOfBounds + ' ' +
  4941.              intToStr(ADaynumber));
  4942.      end
  4943.      else
  4944.           if (ADaynumber > 365) or (ADaynumber < 1) then
  4945.              raise EKronosError.Create(c_DaynumberOutOfBounds + ' ' +
  4946.              intToStr(ADaynumber));
  4947.  
  4948.      T1 := EncodeDate(AYear,1,1);
  4949.      T2 := T1 + ADayNumber - 1;
  4950.      DecodeDate(T2, AYear, M, Md);
  4951.  
  4952.      Result := FetchDateExt(AYear, M, Md);
  4953. end;
  4954.  
  4955. function TKronos.FetchYearType;
  4956. var
  4957.    I : Integer;
  4958.    IndCount : word;
  4959.    DT : TDaytype;
  4960. begin
  4961.       IndCount := 0;
  4962.       I := 0;
  4963.       Result := nil;
  4964.       if DateList.Count = 0 then exit;
  4965.       while (i <= DateList.Count - 1)
  4966.       and (DateList[I] = '0000') do
  4967.       begin
  4968.            DT := TDaytype(DateList.Objects[i]);
  4969.            if (DT.Id >= UserDaytype)
  4970.            and (AYearExt.Year >= DT.FirstShowup)
  4971.            and (AYearExt.Year <= DT.LastShowup)
  4972.            and ((AYearExt.Year - DT.FirstShowUp) mod
  4973.            DT.ShowupFrequency = 0) then
  4974.            begin
  4975.                 inc(IndCount);
  4976.                 if IndCount = AnIndex then
  4977.                    Result := DT;
  4978.            end;
  4979.            inc(I);
  4980.       end;
  4981. end;
  4982.  
  4983. function TKronos.FetchDaytype;
  4984. var
  4985.    OrigCount : Word;
  4986.    OrigIds : TDaytypeID;
  4987. begin
  4988.      OrigCount := FDaytypeCount;
  4989.      OrigIds := FDateExt.DaytypeId;
  4990.      FDaytypeCount := ADateExt.DaytypeCount;
  4991.      FDateExt.DaytypeID := ADateExt.DaytypeID;
  4992.      try
  4993.         Result := GetDaytype(AnIndex);
  4994.      finally
  4995.         FDaytypeCount := OrigCount;
  4996.         FDateExt.DaytypeId := OrigIds;
  4997.      end;
  4998. end;
  4999.  
  5000.  
  5001. procedure TKronos.SaveCD;
  5002. begin
  5003.      FSavedYear := FYear;
  5004.      FSavedDayNumber := FDaynumber;
  5005. end;
  5006.  
  5007. procedure TKronos.RestoreCD;
  5008. begin
  5009.      if FSavedYear = 0 then exit;
  5010.      Year := FSavedYear;
  5011.      DayNumber := FSavedDayNumber;
  5012.      FSavedDayNumber := 0;
  5013.      FSavedYear := 0;
  5014. end;
  5015.  
  5016. procedure TKronos.SaveIntCD;
  5017. begin
  5018.      FIntYear := FYear;
  5019.      FIntDayNumber := FDaynumber;
  5020. end;
  5021.  
  5022. procedure TKronos.RestoreIntCD;
  5023. begin
  5024.      if FIntYear = 0 then exit;
  5025.      Year := FIntYear;
  5026.      DayNumber := FIntDayNumber;
  5027.      FSavedDayNumber := 0;
  5028.      FSavedYear := 0;
  5029. end;
  5030.  
  5031. function TKronos.DOWtoWeekDay;
  5032. {Converts a day of week number to Tweekday type}
  5033. var
  5034.    Nr : word;
  5035. begin
  5036.      if not (ADayOfWeekNumber in [1..7]) then
  5037.         raise EKronosError.Create(c_DayOfWeekNumberOutOfBounds);
  5038.      Nr := (ADayOfWeekNumber + Ord(FFirstWeekDay) - 1);
  5039.      if Nr > 7 then Nr := Nr -7;
  5040.      Result := TWeekday(Nr);
  5041.  
  5042. end;
  5043.  
  5044. function TKronos.DOWtoDaynameIndex;
  5045. {Converts a day of week number to an index that can be used to
  5046. access the Daynames array}
  5047. var
  5048.    FirstDay : word;
  5049. begin
  5050.      if not (ADayOfWeekNumber in [1..7]) then
  5051.         raise EKronosError.Create(c_DayOfWeekNumberOutOfBounds);
  5052.  
  5053.      FirstDay := Ord(FFirstWeekday);
  5054.  
  5055.      inc(ADayOfWeekNumber, FirstDay);
  5056.      if ADayOfWeekNumber > 7 then
  5057.         ADayOfWeekNumber := ADayOfWeeknumber - 7;
  5058.      Result := ADayOfWeekNumber;
  5059. end;
  5060.  
  5061. function TKronos.CDtoDateTime;
  5062. begin
  5063.      Result := EncodeDate(FYear, FMonth, FMonthDay);
  5064. end;
  5065.  
  5066. procedure TKronos.GetMIDayCell;
  5067. {Returns the row and column in the current MonthImage that contains
  5068. ADaynumber}
  5069. var
  5070.    i, j : word;
  5071. begin
  5072.      ARow := 0;
  5073.      ACol := 0;
  5074.      for i := 1 to MonthExt.NumWeeks do
  5075.      begin
  5076.           for j := 1 to 7 do
  5077.           begin
  5078.                if MonthExt.MonthImage[i,j] = ADayNumber then
  5079.                begin
  5080.                     ARow := i;
  5081.                     ACol := j;
  5082.                     exit;
  5083.                end;
  5084.           end;
  5085.      end;
  5086. end;
  5087.  
  5088. function TKronos.GetMIWeekRow;
  5089. {Returns the row in the current MonthImage that contains
  5090. AWeekNumber}
  5091. var
  5092.    I : integer;
  5093. begin
  5094.      Result := 0;
  5095.      for i := 1 to MonthExt.NumWeeks do
  5096.      begin
  5097.           if MonthExt.MonthImage[I,0] = AWeekNumber then
  5098.           begin
  5099.                Result := I;
  5100.                exit;
  5101.           end;
  5102.      end;
  5103. end;
  5104.  
  5105. procedure TKronos.GetFirstMIDayCell;
  5106. {Returns the row and column in the current MonthImage that contains
  5107. the first daynumber}
  5108. var
  5109.    I : integer;
  5110. begin
  5111.      ACol := 0;
  5112.      ARow := 0;
  5113.      for i := 1 to 7 do
  5114.      begin
  5115.           if MonthExt.MonthImage[1, i] > 0 then
  5116.           begin
  5117.                ARow := 1;
  5118.                ACol := I;
  5119.                exit;
  5120.           end;
  5121.      end;
  5122. end;
  5123.  
  5124. procedure TKronos.GetLastMIDayCell;
  5125. {Returns the row and column in the current MonthImage that contains
  5126. the last daynumber}
  5127. var
  5128.    I : integer;
  5129. begin
  5130.      ACol := 0;
  5131.      ARow := 0;
  5132.      for i := 1 to 7 do
  5133.      with MonthExt do
  5134.      begin
  5135.           if MonthImage[NumWeeks, i] < 0 then
  5136.           begin
  5137.                ARow := Numweeks;
  5138.                ACol := I-1;
  5139.                exit;
  5140.           end;
  5141.      end;
  5142.      with MonthExt do
  5143.      begin
  5144.           ARow := NumWeeks;
  5145.           ACol := 7;
  5146.      end;
  5147.  
  5148.  
  5149. end;
  5150.  
  5151.  
  5152. end.
  5153.  
  5154.